diff -Nru menhir-20151112.dfsg/CHANGES menhir-20160808+dfsg/CHANGES --- menhir-20151112.dfsg/CHANGES 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/CHANGES 2016-08-08 19:19:04.000000000 +0000 @@ -1,3 +1,47 @@ +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 +of a parameterized rule, it may itself become parameterized. Menhir +parameterizes it only over the parameters that it actually needs. + +2016/05/04: +In the Coq backend, split the largest definitions into smaller +ones. This circumvenents a limitation of vm_compute on 32 bit +machines. This also enables us to perform sharing between +definitions, so that the generated files are much smaller. + +2016/04/10: +When printing a grammar (which is done by the --only-preprocess options), +remove the leading bar '|', for compatibility with yacc and bison. + +2016/03/11: +In the code back-end, generate type annotations when extracting a semantic +value out of the stack. When working with a semantic value of some function +type, OCaml would incorrectly warn that this function does not use its +argument. This warning should now be gone. + +2016/03/03: +Makefile changes, so as to support ocamlbuild 4.03, which seems to have +stricter hygiene rules than previous versions. + +2015/12/30: +Prevented an incorrect installation that would take place if USE_OCAMLFIND +was given during "make all" but not during "make install". Added a command +line directive --suggest-ocamlfind. + 2015/11/11: Fixed a severe bug in Menhir 20151110 which (when using the code back-end) could cause a generated parser to crash. Thanks to ygrek for reporting the @@ -419,4 +463,3 @@ 2006/01/06: Removed reversed lists from the standard library. - diff -Nru menhir-20151112.dfsg/debian/changelog menhir-20160808+dfsg/debian/changelog --- menhir-20151112.dfsg/debian/changelog 2016-01-17 21:06:40.000000000 +0000 +++ menhir-20160808+dfsg/debian/changelog 2016-08-16 08:06:20.000000000 +0000 @@ -1,3 +1,21 @@ +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 + * New upstream release + * Update Vcs-* + * Switch debian/copyright to format 1.0 + * Bump Standards-Version to 3.9.8 + * Bump debhelper compat to 9 + + -- Stéphane Glondu Sat, 06 Aug 2016 10:55:33 +0200 + menhir (20151112.dfsg-1) unstable; urgency=medium * New upstream release. diff -Nru menhir-20151112.dfsg/debian/compat menhir-20160808+dfsg/debian/compat --- menhir-20151112.dfsg/debian/compat 2016-01-17 20:12:09.000000000 +0000 +++ menhir-20160808+dfsg/debian/compat 2016-08-16 08:00:06.000000000 +0000 @@ -1 +1 @@ -7 +9 diff -Nru menhir-20151112.dfsg/debian/control menhir-20160808+dfsg/debian/control --- menhir-20151112.dfsg/debian/control 2016-01-17 20:12:09.000000000 +0000 +++ menhir-20160808+dfsg/debian/control 2016-08-16 08:00:06.000000000 +0000 @@ -6,14 +6,14 @@ Samuel Mimram , Mehdi Dogguy Build-Depends: - debhelper (>= 7.0.50), + debhelper (>= 9), ocaml-nox (>= 4.02~), ocaml-findlib, dh-ocaml (>= 0.9) -Standards-Version: 3.9.2 +Standards-Version: 3.9.8 Homepage: http://gallium.inria.fr/~fpottier/menhir/ -Vcs-Git: git://anonscm.debian.org/pkg-ocaml-maint/packages/menhir.git -Vcs-Browser: http://anonscm.debian.org/gitweb/?p=pkg-ocaml-maint/packages/menhir.git +Vcs-Git: https://anonscm.debian.org/git/pkg-ocaml-maint/packages/menhir.git +Vcs-Browser: https://anonscm.debian.org/git/pkg-ocaml-maint/packages/menhir.git Package: menhir Architecture: any diff -Nru menhir-20151112.dfsg/debian/copyright menhir-20160808+dfsg/debian/copyright --- menhir-20151112.dfsg/debian/copyright 2016-01-17 20:12:09.000000000 +0000 +++ menhir-20160808+dfsg/debian/copyright 2016-08-16 08:00:06.000000000 +0000 @@ -1,147 +1,143 @@ -This package was debianized by Samuel Mimram on -Wed, 19 Apr 2006 19:11:20 +0200. - -It was downloaded from http://pauillac.inria.fr/~fpottier/menhir/ - -Copyright Holders: François Pottier , Yann Régis-Gianas - -License: - -In the following, "the Library" refers to the following file: - - standard.mly - -and "the Generator" refers to all files marked "Copyright INRIA" in the -root directory. - -The Generator is distributed under the terms of the Q Public License -version 1.0 with a change to choice of law (included below). - -The Library is distributed under the terms of the GNU Library General -Public License version 2 which can be found in -/usr/share/common-licenses/LGPL-2. - -As a special exception to the Q Public Licence, you may develop -application programs, reusable components and other software items -that link with the original or modified versions of the Generator -and are not made available to the general public, without any of the -additional requirements listed in clause 6c of the Q Public licence. - -As a special exception to the GNU Library General Public License, you -may link, statically or dynamically, a "work that uses the Library" -with a publicly distributed version of the Library to produce an -executable file containing portions of the Library, and distribute -that executable file under terms of your choice, without any of the -additional requirements listed in clause 6 of the GNU Library General -Public License. By "a publicly distributed version of the Library", -we mean either the unmodified Library as distributed by INRIA, or a -modified version of the Library that is distributed under the -conditions defined in clause 3 of the GNU Library General Public -License. This exception does not however invalidate any other reasons -why the executable file might be covered by the GNU Library General -Public License. - ----------------------------------------------------------------------- - - THE Q PUBLIC LICENSE version 1.0 - - Copyright (C) 1999 Troll Tech AS, Norway. - Everyone is permitted to copy and - distribute this license document. - -The intent of this license is to establish freedom to share and change -the software regulated by this license under the open source model. - -This license applies to any software containing a notice placed by the -copyright holder saying that it may be distributed under the terms of -the Q Public License version 1.0. Such software is herein referred to -as the Software. This license covers modification and distribution of -the Software, use of third-party application programs based on the -Software, and development of free software which uses the Software. - - Granted Rights - -1. You are granted the non-exclusive rights set forth in this license -provided you agree to and comply with any and all conditions in this -license. Whole or partial distribution of the Software, or software -items that link with the Software, in any form signifies acceptance of -this license. - -2. You may copy and distribute the Software in unmodified form -provided that the entire package, including - but not restricted to - -copyright, trademark notices and disclaimers, as released by the -initial developer of the Software, is distributed. - -3. You may make modifications to the Software and distribute your -modifications, in a form that is separate from the Software, such as -patches. The following restrictions apply to modifications: - - a. Modifications must not alter or remove any copyright notices - in the Software. - - b. When modifications to the Software are released under this - license, a non-exclusive royalty-free right is granted to the - initial developer of the Software to distribute your - modification in future versions of the Software provided such - versions remain available under these terms in addition to any - other license(s) of the initial developer. - -4. You may distribute machine-executable forms of the Software or -machine-executable forms of modified versions of the Software, -provided that you meet these restrictions: - - a. You must include this license document in the distribution. - - b. You must ensure that all recipients of the machine-executable - forms are also able to receive the complete machine-readable - source code to the distributed Software, including all - modifications, without any charge beyond the costs of data - transfer, and place prominent notices in the distribution - explaining this. - - c. You must ensure that all modifications included in the - machine-executable forms are available under the terms of this - license. - -5. You may use the original or modified versions of the Software to -compile, link and run application programs legally developed by you or -by others. - -6. You may develop application programs, reusable components and other -software items that link with the original or modified versions of the -Software. These items, when distributed, are subject to the following -requirements: - - a. You must ensure that all recipients of machine-executable - forms of these items are also able to receive and use the - complete machine-readable source code to the items without any - charge beyond the costs of data transfer. - - b. You must explicitly license all recipients of your items to - use and re-distribute original and modified versions of the - items in both machine-executable and source code forms. The - recipients must be able to do so without any charges whatsoever, - and they must be able to re-distribute to anyone they choose. - - c. If the items are not available to the general public, and the - initial developer of the Software requests a copy of the items, - then you must supply one. - - Limitations of Liability - -In no event shall the initial developers or copyright holders be -liable for any damages whatsoever, including - but not restricted to - -lost revenue or profits or other direct, indirect, special, incidental -or consequential damages, even if they have been advised of the -possibility of such damages, except to the extent invariable law, if -any, provides otherwise. - - No Warranty - -The Software and this license document are provided AS IS with NO -WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - - Choice of Law - -This license is governed by the Laws of France. +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Packaged-By: Samuel Mimram +Packaged-Date: Wed, 19 Apr 2006 19:11:20 +0200 + +Files: * +Copyright: 2005-2015, Inria +License: QPL-1.0-exception + +Files: src/standard.mly +Copyright: 2005-2015, Inria +License: LGPL-2-exception + +License: LGPL-2-exception + The Library is distributed under the terms of the GNU Library General + Public License version 2 which can be found in + /usr/share/common-licenses/LGPL-2. + . + As a special exception to the GNU Library General Public License, you + may link, statically or dynamically, a "work that uses the Library" + with a publicly distributed version of the Library to produce an + executable file containing portions of the Library, and distribute + that executable file under terms of your choice, without any of the + additional requirements listed in clause 6 of the GNU Library General + Public License. By "a publicly distributed version of the Library", + we mean either the unmodified Library as distributed by INRIA, or a + modified version of the Library that is distributed under the + conditions defined in clause 3 of the GNU Library General Public + License. This exception does not however invalidate any other reasons + why the executable file might be covered by the GNU Library General + Public License. + +License: QPL-1.0-exception + The Generator is distributed under the terms of the Q Public License + version 1.0 with a change to choice of law (included below). + . + As a special exception to the Q Public Licence, you may develop + application programs, reusable components and other software items + that link with the original or modified versions of the Generator + and are not made available to the general public, without any of the + additional requirements listed in clause 6c of the Q Public licence. + . + THE Q PUBLIC LICENSE version 1.0 + . + Copyright (C) 1999 Troll Tech AS, Norway. + Everyone is permitted to copy and + distribute this license document. + . + The intent of this license is to establish freedom to share and change + the software regulated by this license under the open source model. + . + This license applies to any software containing a notice placed by the + copyright holder saying that it may be distributed under the terms of + the Q Public License version 1.0. Such software is herein referred to + as the Software. This license covers modification and distribution of + the Software, use of third-party application programs based on the + Software, and development of free software which uses the Software. + . + Granted Rights + . + 1. You are granted the non-exclusive rights set forth in this license + provided you agree to and comply with any and all conditions in this + license. Whole or partial distribution of the Software, or software + items that link with the Software, in any form signifies acceptance of + this license. + . + 2. You may copy and distribute the Software in unmodified form + provided that the entire package, including - but not restricted to - + copyright, trademark notices and disclaimers, as released by the + initial developer of the Software, is distributed. + . + 3. You may make modifications to the Software and distribute your + modifications, in a form that is separate from the Software, such as + patches. The following restrictions apply to modifications: + . + a. Modifications must not alter or remove any copyright notices + in the Software. + . + b. When modifications to the Software are released under this + license, a non-exclusive royalty-free right is granted to the + initial developer of the Software to distribute your + modification in future versions of the Software provided such + versions remain available under these terms in addition to any + other license(s) of the initial developer. + . + 4. You may distribute machine-executable forms of the Software or + machine-executable forms of modified versions of the Software, + provided that you meet these restrictions: + . + a. You must include this license document in the distribution. + . + b. You must ensure that all recipients of the machine-executable + forms are also able to receive the complete machine-readable + source code to the distributed Software, including all + modifications, without any charge beyond the costs of data + transfer, and place prominent notices in the distribution + explaining this. + . + c. You must ensure that all modifications included in the + machine-executable forms are available under the terms of this + license. + . + 5. You may use the original or modified versions of the Software to + compile, link and run application programs legally developed by you or + by others. + . + 6. You may develop application programs, reusable components and other + software items that link with the original or modified versions of the + Software. These items, when distributed, are subject to the following + requirements: + . + a. You must ensure that all recipients of machine-executable + forms of these items are also able to receive and use the + complete machine-readable source code to the items without any + charge beyond the costs of data transfer. + . + b. You must explicitly license all recipients of your items to + use and re-distribute original and modified versions of the + items in both machine-executable and source code forms. The + recipients must be able to do so without any charges whatsoever, + and they must be able to re-distribute to anyone they choose. + . + c. If the items are not available to the general public, and the + initial developer of the Software requests a copy of the items, + then you must supply one. + . + Limitations of Liability + . + In no event shall the initial developers or copyright holders be + liable for any damages whatsoever, including - but not restricted to - + lost revenue or profits or other direct, indirect, special, incidental + or consequential damages, even if they have been advised of the + possibility of such damages, except to the extent invariable law, if + any, provides otherwise. + . + No Warranty + . + The Software and this license document are provided AS IS with NO + WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + . + Choice of Law + . + This license is governed by the Laws of France. diff -Nru menhir-20151112.dfsg/debian/patches/0001-Remove-some-invalid-characters.patch menhir-20160808+dfsg/debian/patches/0001-Remove-some-invalid-characters.patch --- menhir-20151112.dfsg/debian/patches/0001-Remove-some-invalid-characters.patch 2016-01-17 20:13:22.000000000 +0000 +++ menhir-20160808+dfsg/debian/patches/0001-Remove-some-invalid-characters.patch 2016-08-16 08:05:20.000000000 +0000 @@ -19,6 +19,3 @@ .PP This manual page was written by Samuel Mimram , for the Debian project (but may be used by others). --- -2.7.0.rc3 - diff -Nru menhir-20151112.dfsg/debian/patches/0002-Pass-byte-plugin-to-ocamlbuild-when-TARGET-byte.patch menhir-20160808+dfsg/debian/patches/0002-Pass-byte-plugin-to-ocamlbuild-when-TARGET-byte.patch --- menhir-20151112.dfsg/debian/patches/0002-Pass-byte-plugin-to-ocamlbuild-when-TARGET-byte.patch 2016-01-17 20:13:22.000000000 +0000 +++ menhir-20160808+dfsg/debian/patches/0002-Pass-byte-plugin-to-ocamlbuild-when-TARGET-byte.patch 2016-08-16 08:05:20.000000000 +0000 @@ -7,7 +7,7 @@ 1 file changed, 3 insertions(+) diff --git a/src/Makefile b/src/Makefile -index e3af30f..e6a523e 100644 +index 94acf9d..4b5f8d9 100644 --- a/src/Makefile +++ b/src/Makefile @@ -20,6 +20,9 @@ endif @@ -20,6 +20,3 @@ # ---------------------------------------------------------------------------- # For everyday development. --- -2.7.0.rc3 - diff -Nru menhir-20151112.dfsg/debian/rules menhir-20160808+dfsg/debian/rules --- menhir-20151112.dfsg/debian/rules 2016-01-17 21:02:27.000000000 +0000 +++ menhir-20160808+dfsg/debian/rules 2016-08-16 08:00:06.000000000 +0000 @@ -26,4 +26,4 @@ override_dh_auto_test: %: - dh --with ocaml $@ + dh $@ --with ocaml diff -Nru menhir-20151112.dfsg/debian/watch menhir-20160808+dfsg/debian/watch --- menhir-20151112.dfsg/debian/watch 2016-01-17 20:12:09.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-20151112.dfsg/INSTALLATION menhir-20160808+dfsg/INSTALLATION --- menhir-20151112.dfsg/INSTALLATION 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/INSTALLATION 2016-08-08 19:19:04.000000000 +0000 @@ -1,36 +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: +CONFIGURATION CHOICES - make PREFIX=/usr/local all - make PREFIX=/usr/local install - -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: +1- PREFIX - make PREFIX=/usr/local TARGET=byte all - make PREFIX=/usr/local TARGET=byte install - -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, if -available, or placed within $PREFIX/share/menhir. Menhir's --suggest -options help determine where and how it was installed. +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 + +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-20151112.dfsg/Makefile menhir-20160808+dfsg/Makefile --- menhir-20151112.dfsg/Makefile 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/Makefile 2016-08-08 19:19:04.000000000 +0000 @@ -31,6 +31,11 @@ # By default, we attempt to use ocamlfind (if present in the PATH), but it # is possible to prevent that externally by setting USE_OCAMLFIND to false. +# USE_OCAMLFIND is used only at build time (i.e., by "make all"). At +# (un)installation time, instead, we query menhir using --suggest-ocamlfind. +# This should protect us against people who pass USE_OCAMLFIND at build time +# and forget to pass it at (un)installation time. + ifndef USE_OCAMLFIND USE_OCAMLFIND = ocamlfind ocamlc -v >/dev/null 2>&1 endif @@ -164,27 +169,26 @@ # Install the library. mkdir -p $(libdir) install -m 644 $(MLYLIB) $(libdir) - @if $(USE_OCAMLFIND) ; then \ - echo Installing MenhirLib via ocamlfind. ; \ + @if `$(BUILDDIR)/menhir.$(TARGET) --suggest-ocamlfind` ; then \ + 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: - rm -rf $(bindir)/$(MENHIREXE) - rm -rf $(libdir) - @if $(USE_OCAMLFIND) ; then \ - echo Un-installing MenhirLib via ocamlfind. ; \ + @if `$(bindir)/$(MENHIREXE) --suggest-ocamlfind` ; then \ + echo 'Un-installing MenhirLib via ocamlfind.' ; \ ocamlfind remove menhirLib ; \ fi + rm -rf $(bindir)/$(MENHIREXE) + rm -rf $(libdir) rm -rf $(docdir) rm -rf $(mandir)/$(MANS) diff -Nru menhir-20151112.dfsg/src/action.ml menhir-20160808+dfsg/src/action.ml --- menhir-20151112.dfsg/src/action.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/action.ml 2016-08-08 19:19:04.000000000 +0000 @@ -19,7 +19,7 @@ (* Creation. *) -let from_stretch s = { +let from_stretch s = { expr = IL.ETextual s; filenames = [ s.Stretch.stretch_filename ]; keywords = KeywordSet.of_list s.Stretch.stretch_keywords @@ -36,7 +36,7 @@ (* Composition, used during inlining. *) -let compose x a1 a2 = +let compose x a1 a2 = (* 2015/07/20: there used to be a call to [parenthesize_stretch] here, which would insert parentheses around every stretch in [a1]. This is not necessary, as far as I can see, since every stretch that represents @@ -54,10 +54,10 @@ (string * string) list let apply (phi : subst) (s : string) : string = - try + try List.assoc s phi with Not_found -> - s + s let apply_subject (phi : subst) (subject : subject) : subject = match subject with @@ -88,7 +88,7 @@ | SyntaxError -> SyntaxError | Position (subject, where, flavor) -> - let subject', where' = + let subject', where' = match f (subject, where) with | Some (subject', where') -> subject', where' @@ -107,7 +107,7 @@ returning [Some _], or to not transform it, by returning [None]. (In the latter case, [phi] still applies to the keyword.) *) -let rename f phi a = +let rename f phi a = (* Rename all keywords, growing [phi] as we go. *) let keywords = a.keywords in @@ -120,25 +120,25 @@ let phi = List.map (fun (x, y) -> IL.PVar x, IL.EVar y) phi in let expr = IL.ELet (phi, a.expr) in - { + { expr = expr; filenames = a.filenames; keywords = keywords; } -let to_il_expr action = +let to_il_expr action = action.expr -let filenames action = +let filenames action = action.filenames -let keywords action = +let keywords action = action.keywords -let print f action = - let module P = Printer.Make (struct let f = f - let locate_stretches = None - end) +let print f action = + let module P = Printer.Make (struct let f = f + let locate_stretches = None + end) in P.expr action.expr diff -Nru menhir-20151112.dfsg/src/anonymous.ml menhir-20160808+dfsg/src/anonymous.ml --- menhir-20151112.dfsg/src/anonymous.ml 1970-01-01 00:00:00.000000000 +0000 +++ menhir-20160808+dfsg/src/anonymous.ml 2016-08-08 19:19:04.000000000 +0000 @@ -0,0 +1,134 @@ +open Syntax + +(* For each anonymous rule, we define a fresh nonterminal symbol, and + replace the anonymous rule with a reference to this symbol. If the + anonymous rule appears inside a parameterized rule, then we must + define a parameterized nonterminal symbol. *) + +(* ------------------------------------------------------------------------ *) + +(* Computing the free names of some syntactic categories. *) + +let rec fn_parameter accu p = + (* [p] cannot be [ParameterAnonymous _]. *) + let x, ps = Parameters.unapp p in + let accu = StringSet.add (Positions.value x) accu in + fn_parameters accu ps + +and fn_parameters accu ps = + List.fold_left fn_parameter accu ps + +let fn_producer accu (_, p) = + fn_parameter accu p + +let fn_branch accu branch = + List.fold_left fn_producer accu branch.pr_producers + +let fn_branches accu branches = + List.fold_left fn_branch accu branches + +(* ------------------------------------------------------------------------ *) + +(* This functor makes it easy to share mutable internal state between + the functions that follow. *) + +module Run (X : sig end) = struct + +(* ------------------------------------------------------------------------ *) + +(* A fresh name generator. *) + +let fresh : unit -> string = + let next = ref 0 in + fun () -> + Printf.sprintf "__anonymous_%d" (Misc.postincrement next) + +(* ------------------------------------------------------------------------ *) + +(* A rule accumulator. Used to collect the fresh definitions that we + produce. *) + +let rules = + ref [] + +(* ------------------------------------------------------------------------ *) + +(* [anonymous pos parameters branches] deals with an anonymous rule, + at position [pos], which appears inside a possibly-parameterized + rule whose parameters are [parameters], and whose body is + [branches]. We assume that [branches] does not itself contain any + anonymous rules. As a side effect, we create a fresh definition, + and return its name. *) + +let var (symbol : symbol) : parameter = + ParameterVar (Positions.with_pos Positions.dummy symbol) + +let anonymous pos (parameters : symbol list) (branches : parameterized_branch list) : parameter = + (* Compute the free symbols of [branches]. They should form a subset + of [parameters], although we have not yet checked this. We create + a definition that is parameterized only over the parameters that + actually occur free in the definition -- i.e., a definition without + useless parameters. This seems important, as (in some situations) + it avoids duplication and leads to fewer states in the automaton. *) + let used = fn_branches StringSet.empty branches in + let parameters = List.filter (fun x -> StringSet.mem x used) parameters in + (* Generate a fresh non-terminal symbol. *) + let symbol = fresh() in + (* Construct its definition. Note that it is implicitly marked %inline. *) + let rule = { + pr_public_flag = false; + pr_inline_flag = true; + pr_nt = symbol; + pr_positions = [ pos ]; (* this list is not allowed to be empty *) + pr_parameters = parameters; + pr_branches = branches + } in + (* Record this definition. *) + rules := rule :: !rules; + (* Return the symbol that stands for it. *) + Parameters.app (Positions.with_pos pos symbol) (List.map var parameters) + +(* ------------------------------------------------------------------------ *) + +(* Traversal code. *) + +let rec transform_parameter (parameters : symbol list) (p : parameter) : parameter = + match p with + | ParameterVar _ -> + p + | ParameterApp (x, ps) -> + ParameterApp (x, List.map (transform_parameter parameters) ps) + | ParameterAnonymous branches -> + let pos = Positions.position branches + and branches = Positions.value branches in + (* Do not forget the recursive invocation! *) + let branches = List.map (transform_parameterized_branch parameters) branches in + (* This is where the real work is done. *) + anonymous pos parameters branches + +and transform_producer parameters (x, p) = + x, transform_parameter parameters p + +and transform_parameterized_branch parameters branch = + let pr_producers = + List.map (transform_producer parameters) branch.pr_producers + in + { branch with pr_producers } + +let transform_parameterized_rule rule = + let pr_branches = + List.map (transform_parameterized_branch rule.pr_parameters) rule.pr_branches + in + { rule with pr_branches } + +end + +(* ------------------------------------------------------------------------ *) + +(* The main entry point invokes the functor and reads its result. *) + +let transform_partial_grammar g = + let module R = Run(struct end) in + let pg_rules = List.map R.transform_parameterized_rule g.pg_rules in + let pg_rules = !R.rules @ pg_rules in + { g with pg_rules } diff -Nru menhir-20151112.dfsg/src/anonymous.mli menhir-20160808+dfsg/src/anonymous.mli --- menhir-20151112.dfsg/src/anonymous.mli 1970-01-01 00:00:00.000000000 +0000 +++ menhir-20160808+dfsg/src/anonymous.mli 2016-08-08 19:19:04.000000000 +0000 @@ -0,0 +1,3 @@ +open Syntax + +val transform_partial_grammar: partial_grammar -> partial_grammar diff -Nru menhir-20151112.dfsg/src/astar.ml menhir-20160808+dfsg/src/astar.ml --- menhir-20151112.dfsg/src/astar.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/astar.ml 2016-08-08 19:19:04.000000000 +0000 @@ -112,7 +112,7 @@ let add node inode = H.add t node inode - + let get node = H.find t node @@ -160,16 +160,16 @@ inode.priority <- priority; match InfiniteArray.get a priority with | None -> - InfiniteArray.set a priority (Some inode); + InfiniteArray.set a priority (Some inode); (* Decrease [best], if necessary, so as not to miss the new element. In the special case of A*, this never happens. *) assert (!best <= priority); - (* if priority < !best then best := priority *) + (* if priority < !best then best := priority *) | Some inode' -> - inode.next <- inode'; - inode.prev <- inode'.prev; - inode'.prev.next <- inode; - inode'.prev <- inode + inode.next <- inode'; + inode.prev <- inode'.prev; + inode'.prev.next <- inode; + inode'.prev <- inode (* Takes a node off its doubly linked list. Does not adjust [best], as this is not necessary in order to preserve the invariant. *) @@ -179,16 +179,16 @@ InfiniteArray.set a inode.priority None else begin InfiniteArray.set a inode.priority (Some inode.next); - inode.next.prev <- inode.prev; - inode.prev.next <- inode.next; - inode.next <- inode; - inode.prev <- inode + inode.next.prev <- inode.prev; + inode.prev.next <- inode.next; + inode.next <- inode; + inode.prev <- inode end; inode.priority <- -1 let rec get () = if !cardinal = 0 then - None + None else get_nonempty() @@ -207,7 +207,7 @@ let add_or_decrease inode priority = if inode.priority >= 0 then - remove inode; + remove inode; add inode priority end diff -Nru menhir-20151112.dfsg/src/back.ml menhir-20160808+dfsg/src/back.ml --- menhir-20151112.dfsg/src/back.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/back.ml 2016-08-08 19:19:04.000000000 +0000 @@ -23,15 +23,15 @@ let f = open_out filename let locate_stretches = if Settings.infer then - (* Typechecking should not fail at this stage. Omit #line directives. *) - None + (* Typechecking should not fail at this stage. Omit #line directives. *) + None else - (* 2011/10/19: do not use [Filename.basename]. The [#] annotations that - we insert in the [.ml] file must retain their full path. This does - mean that the [#] annotations depend on how menhir is invoked -- e.g. - [menhir foo/bar.mly] and [cd foo && menhir bar.mly] will produce - different files. Nevertheless, this seems useful/reasonable. *) - Some filename + (* 2011/10/19: do not use [Filename.basename]. The [#] annotations that + we insert in the [.ml] file must retain their full path. This does + mean that the [#] annotations depend on how menhir is invoked -- e.g. + [menhir foo/bar.mly] and [cd foo && menhir bar.mly] will produce + different files. Nevertheless, this seems useful/reasonable. *) + Some filename end) in P.program program diff -Nru menhir-20151112.dfsg/src/checkOCamlVersion.ml menhir-20160808+dfsg/src/checkOCamlVersion.ml --- menhir-20151112.dfsg/src/checkOCamlVersion.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/checkOCamlVersion.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,5 +1,7 @@ -(* This module parses ocaml version and confronts it with a user-provided - version. *) +(* This script parses OCaml's version and confronts it with a user-provided + version. It is meant to be run by invoking [ocaml checkOCamlVersion.ml]. *) + +#load "str.cma" (* According to OCaml's manual, the Sys.ocaml_version value follows the regexp [version_regexp]. @@ -7,15 +9,15 @@ let mnum = "\\([0-9]+\\)" (* version = major.minor[.patchlevel][+additional-info]. *) -let version_regexp = - Str.regexp +let version_regexp = + Str.regexp (Printf.sprintf "%s\\.%s\\(\\.%s\\)?\\(\\+\\(.+\\)\\)?" mnum mnum mnum) let must field = function | None -> failwith (Printf.sprintf "\"%s\" field is undefined." field) | Some s -> s -let as_int s = +let as_int s = try int_of_string s with Failure _ -> @@ -23,20 +25,20 @@ exit 1 let parse_version version = - let get i = + let get i = try Some (Str.matched_group i version) with Not_found -> None in if Str.string_match version_regexp version 0 then ( - as_int (must "major" (get 1)), - as_int (must "minor" (get 2)), + as_int (must "major" (get 1)), + as_int (must "minor" (get 2)), get 4, get 6 ) else begin - Printf.eprintf "Failed to retrieve ocaml version.\n"; - exit 1 + Printf.eprintf "Failed to retrieve ocaml version.\n"; + exit 1 end (* The user can compare its version with three different orderings: @@ -52,25 +54,25 @@ let options = Arg.align [ "--eq", Arg.Set eq, " Is the version equal to ?"; - "--eq-strict", Arg.Set eq_strict, + "--eq-strict", Arg.Set eq_strict, " Is the version strictly equal to ? \ (taking into account patchlevel and additional information)"; "--gt", Arg.Set gt, " Is the version newer than ? (default)"; "--lt", Arg.Set lt, " Is the version older than ?"; "--verbose", Arg.Set verbose, " Show version." ] - + let usage = "check-ocaml-version [options] \n" let version = ref None -let set_version s = +let set_version s = version := Some s let _ = Arg.parse options set_version usage -let compare, compare_str, strict = +let compare, compare_str, strict = match !eq, !gt, !lt with | true, false, false -> ( = ) , "", !eq_strict | false, true, false -> ( >= ), "or greater ", false @@ -79,32 +81,32 @@ | _ -> failwith "(eq|gt|lt) flags must be used independently" let compare_version (major, minor, p, a) (major', minor', p', a') = - if major = major' then + if major = major' then if minor = minor' then if strict then - (p = p') && (a = a') + (p = p') && (a = a') else true else compare minor minor' - else - compare major major' + else + compare major major' let _ = match !version with | None -> - Printf.printf "%s\n%!" Sys.ocaml_version + Printf.printf "%s\n%!" Sys.ocaml_version | Some version -> - let ov = parse_version Sys.ocaml_version - and uv = parse_version version in - if compare_version ov uv then begin - if !verbose then - Printf.printf "Version %s is OK.\n%!" Sys.ocaml_version; - exit 0 - end - else begin - if !verbose then - Printf.printf "%s is NOT OK: version %s %swas required.%!\n" Sys.ocaml_version version compare_str; - exit 1 - end + let ov = parse_version Sys.ocaml_version + and uv = parse_version version in + if compare_version ov uv then begin + if !verbose then + Printf.printf "Version %s is OK.\n%!" Sys.ocaml_version; + exit 0 + end + else begin + if !verbose then + Printf.printf "%s is NOT OK: version %s %swas required.%!\n" Sys.ocaml_version version compare_str; + exit 1 + end diff -Nru menhir-20151112.dfsg/src/codeBackend.ml menhir-20160808+dfsg/src/codeBackend.ml --- menhir-20151112.dfsg/src/codeBackend.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/codeBackend.ml 2016-08-08 19:19:04.000000000 +0000 @@ -355,11 +355,11 @@ Nonterminal.tabulate (fun nt -> not ( Lr1.targets (fun accu _ target -> - accu && - match Invariant.has_default_reduction target with - | Some (prod, _) -> - Production.length prod > 0 - | None -> false + accu && + match Invariant.has_default_reduction target with + | Some (prod, _) -> + Production.length prod > 0 + | None -> false ) true (Symbol.N nt) ) ) @@ -457,15 +457,15 @@ Nonterminal.fold (fun nt accu -> accu && if gotopushes nt then - true + true else - Lr1.targets (fun accu _ target -> - accu && - match Invariant.has_default_reduction target with - | Some (prod, _) -> - shiftreduce prod - | None -> - false + Lr1.targets (fun accu _ target -> + accu && + match Invariant.has_default_reduction target with + | Some (prod, _) -> + shiftreduce prod + | None -> + false ) true (Symbol.N nt) ) true ) @@ -480,14 +480,14 @@ typename = tcstate; typeparams = []; typerhs = TDefSum ( - Lr1.fold (fun defs s -> - if Invariant.represented s then { - dataname = statecon s; - datavalparams = []; - datatypeparams = None - } :: defs - else defs - ) [] + Lr1.fold (fun defs s -> + if Invariant.represented s then { + dataname = statecon s; + datavalparams = []; + datatypeparams = None + } :: defs + else defs + ) [] ); typeconstraint = None } @@ -521,15 +521,15 @@ field false flexbuf tlexbuf; (* The last token that was read from the lexer. This is the - head of the token stream, unless [env.error] is set. *) + head of the token stream, unless [env.error] is set. *) field false ftoken ttoken; (* A flag which tells whether we currently have an [error] token at the head of the stream. When this flag is set, the head - of the token stream is the [error] token, and the contents of - the [token] field is irrelevant. The token following [error] - is obtained by invoking the lexer again. *) + of the token stream is the [error] token, and the contents of + the [token] field is irrelevant. The token following [error] + is obtained by invoking the lexer again. *) field true ferror tbool; @@ -554,7 +554,7 @@ let curryif flag t = if flag then curry t else t -(* Types for stack cells. +(* Types for stack cells. [celltype tailtype holds_state symbol] returns the type of a stack cell. The parameter [tailtype] is the type of the tail of the @@ -577,7 +577,7 @@ elementif (Invariant.startp symbol) tposition ) -(* Types for stacks. +(* Types for stacks. [stacktype s] is the type of the stack at state [s]. [reducestacktype prod] is the type of the stack when about to reduce production [prod]. @@ -626,7 +626,7 @@ let reduce_expects_state_param prod = let nt = Production.nt prod in - Production.length prod = 0 && + Production.length prod = 0 && Invariant.fold (fun _ holds_state _ _ -> holds_state) false (Invariant.gotostack nt) (* The type of the [reduce] function. If shiftreduce optimization @@ -637,9 +637,9 @@ auto2scheme ( arrow tenv ( curryif (shiftreduce prod) ( - arrow (reducestacktype prod) ( - arrowif (reduce_expects_state_param prod) tstate tresult - ) + arrow (reducestacktype prod) ( + arrowif (reduce_expects_state_param prod) tstate tresult + ) ) ) ) @@ -715,10 +715,14 @@ let reducecellparams prod i holds_state symbol = let ids = Production.identifiers prod in - (* The semantic value is bound to the variable [ids.(i)]. *) + (* The semantic value is bound to the variable [ids.(i)]. Its type is [t]. As + of 2016/03/11, we generate a type annotation. Indeed, because of our use of + [magic], the semantic value would otherwise have an unknown type; and, if + it is a function, the OCaml compiler could warn (incorrectly) that this + function does not use its argument. *) - let semvpat _t = - PVar ids.(i) + let semvpat t = + PAnnot (PVar ids.(i), t) in elementif (Invariant.endp symbol) (PVar (Printf.sprintf "_endpos_%s_" ids.(i))) @ @@ -839,7 +843,7 @@ tokspat toks; branchbody = call_reduce prod s - } + } (* Code for shifting from state [s] to state [s'] via the token [tok]. This produces a branch, to be inserted in a [run] function for @@ -926,16 +930,16 @@ assert (TerminalSet.cardinal toks = 1); (* There is a default reduction on token [#]. We cannot - request the next token, since that might drive the - lexer off the end of the input stream, so we cannot - call [discard]. Do nothing. *) + request the next token, since that might drive the + lexer off the end of the input stream, so we cannot + call [discard]. Do nothing. *) e | (Some (Symbol.T _) | None), Some _ -> (* There is some other default reduction. Discard the first - input token. *) + input token. *) blet ([ PVar env, EApp (EVar discard, [ EVar env ]) @@ -945,7 +949,7 @@ | (Some (Symbol.T _) | None), None -> (* There is no default reduction. Discard the first input token - and peek at the next one. *) + and peek at the next one. *) blet ([ PVar env, EApp (EVar discard, [ EVar env ]); @@ -955,28 +959,28 @@ | Some (Symbol.N _), Some _ -> (* There is some default reduction. Do not peek at the input - token. *) + token. *) e | Some (Symbol.N _), None -> (* There is no default reduction. Peek at the first input token, - without taking it off the input stream. This is normally done - by reading [env.token], unless the token might be [error]: - then, we check [env.error] first. *) + without taking it off the input stream. This is normally done + by reading [env.token], unless the token might be [error]: + then, we check [env.error] first. *) if Invariant.errorpeeker s then begin - incr errorpeekers; - EIfThenElse ( - ERecordAccess (EVar env, ferror), - tracecomment "Resuming error handling" (call_error_via_errorcase magic s), - blet ([ PVar token, ERecordAccess (EVar env, ftoken) ], e) + incr errorpeekers; + EIfThenElse ( + ERecordAccess (EVar env, ferror), + tracecomment "Resuming error handling" (call_error_via_errorcase magic s), + blet ([ PVar token, ERecordAccess (EVar env, ftoken) ], e) ) end else - blet ([ assertnoerror; - PVar token, ERecordAccess (EVar env, ftoken) ], e) + blet ([ assertnoerror; + PVar token, ERecordAccess (EVar env, ftoken) ], e) (* This produces the header of a [run] function. *) @@ -1047,7 +1051,7 @@ (* Perform reduction without looking ahead. - If shiftreduce optimization is being performed, then no + If shiftreduce optimization is being performed, then no stack cell is allocated. The contents of the top stack cell are passed do [reduce] as extra parameters. *) @@ -1064,46 +1068,46 @@ | None -> (* If this state is willing to act on the error token, ignore - that -- this is taken care of elsewhere. *) + that -- this is taken care of elsewhere. *) let transitions = - SymbolMap.remove (Symbol.T Terminal.error) (Lr1.transitions s) + SymbolMap.remove (Symbol.T Terminal.error) (Lr1.transitions s) and reductions = - TerminalMap.remove Terminal.error (Lr1.reductions s) + TerminalMap.remove Terminal.error (Lr1.reductions s) in (* Construct the main case analysis that determines what action - should be taken next. + should be taken next. - A default branch, where an error is detected, is added if the - analysis is not exhaustive. In the default branch, we - initiate error handling. *) + A default branch, where an error is detected, is added if the + analysis is not exhaustive. In the default branch, we + initiate error handling. *) let covered, branches = - ProductionMap.fold (fun prod toks (covered, branches) -> - (* There is a reduction for these tokens. *) - TerminalSet.union toks covered, - reducebranch toks prod s :: branches - ) (Lr1.invert reductions) (TerminalSet.empty, []) + ProductionMap.fold (fun prod toks (covered, branches) -> + (* There is a reduction for these tokens. *) + TerminalSet.union toks covered, + reducebranch toks prod s :: branches + ) (Lr1.invert reductions) (TerminalSet.empty, []) in let covered, branches = - SymbolMap.fold (fun symbol s' (covered, branches) -> - match symbol with - | Symbol.T tok -> - (* There is a shift transition for this token. *) - TerminalSet.add tok covered, - shiftbranch s tok s' :: branches - | Symbol.N _ -> - covered, branches - ) transitions (covered, branches) + SymbolMap.fold (fun symbol s' (covered, branches) -> + match symbol with + | Symbol.T tok -> + (* There is a shift transition for this token. *) + TerminalSet.add tok covered, + shiftbranch s tok s' :: branches + | Symbol.N _ -> + covered, branches + ) transitions (covered, branches) in let branches = - if TerminalSet.subset TerminalSet.universe covered then - branches - else - branches @ [ { branchpat = PWildcard; branchbody = initiate s } ] + if TerminalSet.subset TerminalSet.universe covered then + branches + else + branches @ [ { branchpat = PWildcard; branchbody = initiate s } ] in (* Finally, construct the code for [run]. The former pushes things @@ -1111,14 +1115,14 @@ case analysis on the lookahead token. *) runheader s ( - runpushcell s ( - gettoken s None ( + runpushcell s ( + gettoken s None ( EMatch ( EVar token, branches ) - ) - ) + ) + ) ) (* This is the body of the [reduce] function associated with @@ -1147,9 +1151,9 @@ Invariant.fold (fun (i, pat) holds_state symbol _ -> i + 1, if i = length - 1 && shiftreduce prod then - pat + pat else - ptuple (pat :: reducecellparams prod i holds_state symbol) + ptuple (pat :: reducecellparams prod i holds_state symbol) ) (0, PVar stack) (Invariant.prodstack prod) in @@ -1164,9 +1168,9 @@ Misc.foldi length (fun i unitbindings -> match semvtype rhs.(i) with | [] -> - (PVar ids.(i), EUnit) :: unitbindings + (PVar ids.(i), EUnit) :: unitbindings | _ -> - unitbindings + unitbindings ) [] in @@ -1197,18 +1201,18 @@ ) @ elementif bind_startp ( if length > 0 then - PVar startp, - EVar (Printf.sprintf "_startpos_%s_" ids.(0)) + PVar startp, + EVar (Printf.sprintf "_startpos_%s_" ids.(0)) else extract startp ) @ elementif (Invariant.endp symbol) ( if length > 0 then - PVar endp, - EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1)) + PVar endp, + EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1)) else if bind_startp then PVar endp, - EVar startp + EVar startp else extract endp ) @@ -1225,9 +1229,9 @@ tracecomment "Accepting" (blet ( - [ pat, EVar stack ], - EMagic (EVar ids.(0)) - )) + [ pat, EVar stack ], + EMagic (EVar ids.(0)) + )) else @@ -1241,17 +1245,17 @@ tracecomment (Printf.sprintf "Reducing production %s" (Production.print prod)) (blet ( - (pat, EVar stack) :: - unitbindings @ - posbindings action, - - (* If the semantic action is susceptible of raising [Error], - use a [let/unless] construct, otherwise use [let]. *) - - if Action.has_syntaxerror action then - letunless act semv (call_goto nt) (errorbookkeeping call_errorcase) - else - blet ([ PVar semv, act ], call_goto nt) + (pat, EVar stack) :: + unitbindings @ + posbindings action, + + (* If the semantic action is susceptible of raising [Error], + use a [let/unless] construct, otherwise use [let]. *) + + if Action.has_syntaxerror action then + letunless act semv (call_goto nt) (errorbookkeeping call_errorcase) + else + blet ([ PVar semv, act ], call_goto nt) )) (* This is the definition of the [reduce] function associated with @@ -1292,10 +1296,10 @@ let branches = Lr1.targets (fun branches sources target -> { - branchpat = - pstatescon sources; - branchbody = - call_run target (runparams magic var target) + branchpat = + pstatescon sources; + branchbody = + call_run target (runparams magic var target) } :: branches ) [] (Symbol.N nt) in @@ -1304,18 +1308,18 @@ | [] -> (* If there are no branches, then this [goto] function is never - invoked. The inliner will drop it, so whatever we generate - here is unimportant. *) + invoked. The inliner will drop it, so whatever we generate + here is unimportant. *) call_assertfalse | [ branch ] -> (* If there is only one branch, no case analysis is required. This - optimization is not strictly necessary if GADTs are used by the - compiler to prove that the case analysis is exhaustive. It does - improve readability, though, and is also useful if the compiler - does not have GADTs. *) + optimization is not strictly necessary if GADTs are used by the + compiler to prove that the case analysis is exhaustive. It does + improve readability, though, and is also useful if the compiler + does not have GADTs. *) EPatComment ( "State should be ", @@ -1326,9 +1330,9 @@ | _ -> (* In the general case, we keep the branches computed above and, - unless [nt] is universal, add a default branch, which is - theoretically useless but helps avoid warnings if the - compiler does not have GADTs. *) + unless [nt] is universal, add a default branch, which is + theoretically useless but helps avoid warnings if the + compiler does not have GADTs. *) let default = { branchpat = PWildcard; @@ -1346,7 +1350,7 @@ false; valpat = PVar (goto nt); - valval = + valval = EAnnot (EFun (gotoparams pvar nt, gotopushcell nt (gotobody nt)), gototypescheme nt) } @@ -1374,19 +1378,19 @@ let prod = Misc.single prods in (* There is a reduce transition on error. If shiftreduce - optimization is enabled for this production, then we must pop - an extra cell for [reduce]'s calling convention to be met. *) + optimization is enabled for this production, then we must pop + an extra cell for [reduce]'s calling convention to be met. *) let extrapop e = - if shiftreduce prod then - let pat = - ptuple (PVar stack :: Invariant.fold_top (runcellparams pvar) [] (Invariant.stack s)) - in - blet ([ pat, EVar stack ], e) - else - e + if shiftreduce prod then + let pat = + ptuple (PVar stack :: Invariant.fold_top (runcellparams pvar) [] (Invariant.stack s)) + in + blet ([ pat, EVar stack ], e) + else + e in - + handle s ( extrapop ( call_reduce prod s @@ -1397,21 +1401,21 @@ (* This state is unable to handle errors. Pop the stack to find a state that does handle errors, a state that can further pop - the stack, or die. *) + the stack, or die. *) match Invariant.rewind s with | Invariant.Die -> - can_die := true; + can_die := true; ERaise errorval | Invariant.DownTo (w, st) -> - let _, pat = Invariant.fold errorcellparams (0, PVar stack) w in - blet ( - [ pat, EVar stack ], - match st with - | Invariant.Represented -> - call_errorcase - | Invariant.UnRepresented s -> - call_error magic s + let _, pat = Invariant.fold errorcellparams (0, PVar stack) w in + blet ( + [ pat, EVar stack ], + match st with + | Invariant.Represented -> + call_errorcase + | Invariant.UnRepresented s -> + call_error magic s ) (* This is the [error] function associated with state [s]. *) @@ -1438,12 +1442,12 @@ let branches = Lr1.fold (fun branches s -> if Invariant.represented s then - { - branchpat = pstatecon s; - branchbody = EApp (EVar (error s), [ EVar env; EMagic (EVar stack) ]) + { + branchpat = pstatecon s; + branchbody = EApp (EVar (error s), [ EVar env; EMagic (EVar stack) ]) } :: branches else - branches + branches ) [] in { @@ -1453,14 +1457,14 @@ PVar errorcase; valval = EAnnot ( - EFun ( - errorcaseparams nomagic pvar, - EMatch ( - EVar state, - branches - ) - ), - errorcasetypescheme + EFun ( + errorcaseparams nomagic pvar, + EMatch ( + EVar state, + branches + ) + ), + errorcasetypescheme ) } @@ -1472,15 +1476,15 @@ This is a public definition. The code initializes a parser environment, an empty stack, and invokes - [run]. - + [run]. + 2015/11/11. If the state [s] can reduce an epsilon production whose left-hand symbol keeps track of its start or end position, or if [s] can reduce any production that mentions [$endpos($0)], then the initial stack should contain a sentinel cell with a valid [endp] field at offset 1. For simplicity, we always create a sentinel cell. *) -let entrydef s = +let entrydef s = let nt = Item.startnt (Lr1.start2item s) in let lexer = "lexer" and lexbuf = "lexbuf" in @@ -1495,14 +1499,14 @@ valpat = PVar (Nonterminal.print true nt); valval = EAnnot ( EFun ( [ PVar lexer; PVar lexbuf ], - blet ( - [ PVar env, EApp (EVar initenv, [ EVar lexer; EVar lexbuf ]) ], - EMagic (EApp (EVar (run s), [ EVar env; initial_stack ])) - ) - ), + blet ( + [ PVar env, EApp (EVar initenv, [ EVar lexer; EVar lexbuf ]) ], + EMagic (EApp (EVar (run s), [ EVar env; initial_stack ])) + ) + ), entrytypescheme Front.grammar (Nonterminal.print true nt) ) - } + } (* ------------------------------------------------------------------------ *) (* Code production for auxiliary functions. *) @@ -1513,16 +1517,16 @@ let assertfalsedef = { valpublic = false; valpat = PVar assertfalse; - valval = + valval = EAnnot ( EFun ([ PUnit ], - blet ([ - PUnit, EApp (EVar "Printf.fprintf", - [ EVar "Pervasives.stderr"; - EStringConst "Internal failure -- please contact the parser generator's developers.\n%!" ]); - ], - EApp (EVar "assert", [ efalse ]) - ) + blet ([ + PUnit, EApp (EVar "Printf.fprintf", + [ EVar "Pervasives.stderr"; + EStringConst "Internal failure -- please contact the parser generator's developers.\n%!" ]); + ], + EApp (EVar "assert", [ efalse ]) + ) ), scheme [ "a" ] (arrow tunit (tvar "a")) ) @@ -1600,25 +1604,25 @@ { valpublic = false; valpat = PVar initenv; - valval = + valval = EAnnot ( - EFun ( [ PVar lexer; PVar lexbuf ], - blet ( + EFun ( [ PVar lexer; PVar lexbuf ], + blet ( (* We do not have a dummy token at hand, so we forge one. *) (* It will be overwritten by the first call to the lexer. *) - [ PVar token, EMagic EUnit ], - ERecord ([ - (flexer, EVar lexer); - (flexbuf, EVar lexbuf); - (ftoken, EVar token); - (ferror, efalse) - ] - ) - ) - ), + [ PVar token, EMagic EUnit ], + ERecord ([ + (flexer, EVar lexer); + (flexbuf, EVar lexbuf); + (ftoken, EVar token); + (ferror, efalse) + ] + ) + ) + ), type2scheme (marrow [ tlexer; tlexbuf ] tenv) ) - } + } (* ------------------------------------------------------------------------ *) (* Here is complete code for the parser. *) @@ -1632,13 +1636,7 @@ [ SIFunctor (grammar.parameters, - SIExcDefs [ excdef ] :: - - SIValDefs (false, [ excvaldef ]) :: - - interface_to_structure ( - tokentypedef grammar - ) @ + mbasics grammar @ SITypeDefs [ envtypedef; statetypedef ] :: @@ -1676,11 +1674,10 @@ let () = if not !can_die then - Error.logC 1 (fun f -> Printf.fprintf f + Error.logC 1 (fun f -> Printf.fprintf f "The generated parser cannot raise Error.\n") let () = Time.tick "Producing abstract syntax" end - diff -Nru menhir-20151112.dfsg/src/codeBits.ml menhir-20160808+dfsg/src/codeBits.ml --- menhir-20151112.dfsg/src/codeBits.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/codeBits.ml 2016-08-08 19:19:04.000000000 +0000 @@ -74,7 +74,7 @@ { quantifiers = qs; body = t - } + } (* Building a type scheme with no quantifiers out of a type. *) @@ -210,7 +210,7 @@ [ SITypeDefs defs ] | IIFunctor (_, _) | IIValDecls _ - | IIInclude _ + | IIInclude _ | IIModule (_, _) | IIComment _ -> [] diff -Nru menhir-20151112.dfsg/src/codePieces.ml menhir-20160808+dfsg/src/codePieces.ml --- menhir-20151112.dfsg/src/codePieces.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/codePieces.ml 2016-08-08 19:19:04.000000000 +0000 @@ -71,8 +71,8 @@ | None -> (* [nt] has unknown type. If we we have run [Infer], then this - can't happen. However, running type inference is only an - option, so we still have to deal with that case. *) + can't happen. However, running type inference is only an + option, so we still have to deal with that case. *) TypVar (ntvar nt) @@ -179,15 +179,15 @@ valval = EAnnot ( EFun ([ PVar token ], - EMatch (EVar token, - Terminal.fold (fun tok branches -> - if Terminal.pseudo tok then - branches - else - { branchpat = (if bindsemv then tokpatv else tokpat) tok; - branchbody = branch tok } :: branches - ) [] - ) + EMatch (EVar token, + Terminal.fold (fun tok branches -> + if Terminal.pseudo tok then + branches + else + { branchpat = (if bindsemv then tokpatv else tokpat) tok; + branchbody = branch tok } :: branches + ) [] + ) ), type2scheme (arrow TokenType.ttoken codomain) ) @@ -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-20151112.dfsg/src/codePieces.mli menhir-20160808+dfsg/src/codePieces.mli --- menhir-20151112.dfsg/src/codePieces.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/codePieces.mli 2016-08-08 19:19:04.000000000 +0000 @@ -15,7 +15,7 @@ (* The variable that holds the environment. This is a parameter to all functions. We do not make it a global variable because we wish to - preserve re-entrancy. *) + preserve re-entrancy. *) val env : string @@ -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-20151112.dfsg/src/compressedBitSet.ml menhir-20160808+dfsg/src/compressedBitSet.ml --- menhir-20151112.dfsg/src/compressedBitSet.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/compressedBitSet.ml 2016-08-08 19:19:04.000000000 +0000 @@ -22,68 +22,68 @@ | C _ -> false -let add i s = +let add i s = let ioffset = i mod word_size in let iaddr = i - ioffset and imask = 1 lsl ioffset in let rec add = function | N -> - (* Insert at end. *) - C (iaddr, imask, N) + (* Insert at end. *) + C (iaddr, imask, N) | C (addr, ss, qs) as s -> - if iaddr < addr then - (* Insert in front. *) - C (iaddr, imask, s) - else if iaddr = addr then - (* Found appropriate cell, update bit field. *) - let ss' = ss lor imask in - if ss' = ss then - s - else - C (addr, ss', qs) - else - (* Not there yet, continue. *) - let qs' = add qs in - if qs == qs' then - s - else - C (addr, ss, qs') + if iaddr < addr then + (* Insert in front. *) + C (iaddr, imask, s) + else if iaddr = addr then + (* Found appropriate cell, update bit field. *) + let ss' = ss lor imask in + if ss' = ss then + s + else + C (addr, ss', qs) + else + (* Not there yet, continue. *) + let qs' = add qs in + if qs == qs' then + s + else + C (addr, ss, qs') in add s - -let singleton i = + +let singleton i = add i N -let remove i s = +let remove i s = let ioffset = i mod word_size in let iaddr = i - ioffset and imask = 1 lsl ioffset in let rec remove = function | N -> - N + N | C (addr, ss, qs) as s -> - if iaddr < addr then - s - else if iaddr = addr then - (* Found appropriate cell, update bit field. *) - let ss' = ss land (lnot imask) in - if ss' = 0 then - qs - else if ss' = ss then - s - else - C (addr, ss', qs) - else - (* Not there yet, continue. *) - let qs' = remove qs in - if qs == qs' then - s - else - C (addr, ss, qs') + if iaddr < addr then + s + else if iaddr = addr then + (* Found appropriate cell, update bit field. *) + let ss' = ss land (lnot imask) in + if ss' = 0 then + qs + else if ss' = ss then + s + else + C (addr, ss', qs) + else + (* Not there yet, continue. *) + let qs' = remove qs in + if qs == qs' then + s + else + C (addr, ss, qs') in remove s - -let rec fold f s accu = + +let rec fold f s accu = match s with | N -> accu @@ -112,78 +112,78 @@ | N -> false -let cardinal s = +let cardinal s = fold (fun _ m -> m + 1) s 0 let elements s = fold (fun tl hd -> tl :: hd) s [] -let rec subset s1 s2 = +let rec subset s1 s2 = match s1, s2 with | N, _ -> true | _, N -> false - | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> if addr1 < addr2 then - false + false else if addr1 = addr2 then - if (ss1 land ss2) <> ss1 then - false - else - subset qs1 qs2 - else - subset s1 qs2 + if (ss1 land ss2) <> ss1 then + false + else + subset qs1 qs2 + else + subset s1 qs2 let mem i s = subset (singleton i) s -let rec union s1 s2 = +let rec union s1 s2 = match s1, s2 with | N, s | s, N -> s | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> if addr1 < addr2 then - C (addr1, ss1, union qs1 s2) + C (addr1, ss1, union qs1 s2) else if addr1 > addr2 then - let s = union s1 qs2 in - if s == qs2 then - s2 - else - C (addr2, ss2, s) - else - let ss = ss1 lor ss2 in - let s = union qs1 qs2 in - if ss == ss2 && s == qs2 then - s2 - else - C (addr1, ss, s) + let s = union s1 qs2 in + if s == qs2 then + s2 + else + C (addr2, ss2, s) + else + let ss = ss1 lor ss2 in + let s = union qs1 qs2 in + if ss == ss2 && s == qs2 then + s2 + else + C (addr1, ss, s) -let rec inter s1 s2 = +let rec inter s1 s2 = match s1, s2 with | N, _ | _, N -> N | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> if addr1 < addr2 then - inter qs1 s2 + inter qs1 s2 else if addr1 > addr2 then - inter s1 qs2 - else - let ss = ss1 land ss2 in - let s = inter qs1 qs2 in - if ss = 0 then - s - else - if (ss = ss1) && (s == qs1) then - s1 - else - C (addr1, ss, s) + inter s1 qs2 + else + let ss = ss1 land ss2 in + let s = inter qs1 qs2 in + if ss = 0 then + s + else + if (ss = ss1) && (s == qs1) then + s1 + else + C (addr1, ss, s) exception Found of int -let choose s = +let choose s = try iter (fun x -> raise (Found x) @@ -192,34 +192,34 @@ with Found x -> x -let rec compare s1 s2 = +let rec compare s1 s2 = match s1, s2 with N, N -> 0 | _, N -> 1 | N, _ -> -1 | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> - if addr1 < addr2 then -1 - else if addr1 > addr2 then 1 - else if ss1 < ss2 then -1 - else if ss1 > ss2 then 1 - else compare qs1 qs2 + if addr1 < addr2 then -1 + else if addr1 > addr2 then 1 + else if ss1 < ss2 then -1 + else if ss1 > ss2 then 1 + else compare qs1 qs2 let equal s1 s2 = compare s1 s2 = 0 -let rec disjoint s1 s2 = +let rec disjoint s1 s2 = match s1, s2 with | N, _ | _, N -> true - | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> if addr1 = addr2 then - if (ss1 land ss2) = 0 then - disjoint qs1 qs2 - else - false - else if addr1 < addr2 then - disjoint qs1 s2 - else - disjoint s1 qs2 + if (ss1 land ss2) = 0 then + disjoint qs1 qs2 + else + false + else if addr1 < addr2 then + disjoint qs1 s2 + else + disjoint s1 qs2 diff -Nru menhir-20151112.dfsg/src/concreteSyntax.mli menhir-20160808+dfsg/src/concreteSyntax.mli --- menhir-20151112.dfsg/src/concreteSyntax.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/concreteSyntax.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -type grammar = - { - pg_filename : Syntax.filename; - pg_declarations : (Syntax.declaration Positions.located) list; - pg_rules : Syntax.parameterized_rule list; - pg_trailer : Syntax.trailer option; - } - - diff -Nru menhir-20151112.dfsg/src/conflict.ml menhir-20160808+dfsg/src/conflict.ml --- menhir-20151112.dfsg/src/conflict.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/conflict.ml 2016-08-08 19:19:04.000000000 +0000 @@ -49,14 +49,14 @@ | (item, offset) :: configs -> let _, _, rhs, pos, _ = Item.def item in let derivation = - if offset = offset' then - (* This is an epsilon transition. Put a new root node on top of - the existing derivation. *) - Derivation.build pos rhs derivation None - else - (* This was a shift transition. Tack symbol in front of the - forest. *) - Derivation.prepend rhs.(pos) derivation + if offset = offset' then + (* This is an epsilon transition. Put a new root node on top of + the existing derivation. *) + Derivation.build pos rhs derivation None + else + (* This was a shift transition. Tack symbol in front of the + forest. *) + Derivation.prepend rhs.(pos) derivation in follow derivation offset configs @@ -105,36 +105,36 @@ Misc.qiter (function (item, offset) as config -> (* If the item we're looking at is the goal item and if - we have read all of the input symbols, stop. *) + we have read all of the input symbols, stop. *) if (Item.equal item stop) && (offset = n) then - raise Done; + raise Done; (* Otherwise, explore the transitions out of this item. *) let prod, _, rhs, pos, length = Item.def item in (* Shift transition, followed only if the symbol matches - the symbol found in the input string. *) + the symbol found in the input string. *) if (pos < length) && (offset < n) && (Symbol.equal rhs.(pos) input.(offset)) then begin - let config' = (Item.import (prod, pos+1), offset+1) in - enqueue (Some config) config' + let config' = (Item.import (prod, pos+1), offset+1) in + enqueue (Some config) config' end; (* Epsilon transitions. *) if pos < length then - match rhs.(pos) with - | Symbol.N nt -> - Production.iternt nt (fun prod -> - let config' = (Item.import (prod, 0), offset) in - enqueue (Some config) config' + match rhs.(pos) with + | Symbol.N nt -> + Production.iternt nt (fun prod -> + let config' = (Item.import (prod, 0), offset) in + enqueue (Some config) config' ) - | Symbol.T _ -> - () + | Symbol.T _ -> + () ) queue; assert false @@ -187,65 +187,65 @@ | [] -> assert (Terminal.equal tok Terminal.sharp); (* One could emit a comment saying that the lookahead token is - initially [#]. That comment would have to be displayed above - the derivation, though, and there is no support for that - at the moment, so let's skip it. *) + initially [#]. That comment would have to be displayed above + the derivation, though, and there is no support for that + at the moment, so let's skip it. *) derivation | (item, _, offset) :: configs -> 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_prod prod (pos + 1) in + (* This is an epsilon transition. Attack a new line and add + a comment that explains why the lookahead symbol is + produced or inherited. *) - if TerminalSet.mem tok first then + let nullable, first = Analysis.nullable_first_prod prod (pos + 1) in - (* The lookahead symbol is produced (and perhaps also inherited, - but let's ignore that). *) + if TerminalSet.mem tok first then - let e = Analysis.explain_first_rhs tok rhs (pos + 1) in - let comment = - "lookahead token appears" ^ (if e = "" then "" else " because " ^ e) - in - let derivation = - Derivation.build pos rhs derivation (Some comment) - in + (* The lookahead symbol is produced (and perhaps also inherited, + but let's ignore that). *) - (* Print the rest of the derivation without paying attention to - the lookahead symbols. *) + let e = Analysis.explain_first_rhs tok rhs (pos + 1) in + let comment = + "lookahead token appears" ^ (if e = "" then "" else " because " ^ e) + in + let derivation = + Derivation.build pos rhs derivation (Some comment) + in - follow derivation offset (List.map config1toconfig0 configs) + (* Print the rest of the derivation without paying attention to + the lookahead symbols. *) - else begin + follow derivation offset (List.map config1toconfig0 configs) - (* The lookahead symbol is not produced, so it is definitely inherited. *) + else begin - assert nullable; + (* The lookahead symbol is not produced, so it is definitely inherited. *) - let comment = - "lookahead token is inherited" ^ - (if pos + 1 < length then Printf.sprintf " because %scan vanish" (Symbol.printao (pos + 1) rhs) else "") - in - let derivation = - Derivation.build pos rhs derivation (Some comment) - in + assert nullable; - follow1 tok derivation offset configs + let comment = + "lookahead token is inherited" ^ + (if pos + 1 < length then Printf.sprintf " because %scan vanish" (Symbol.printao (pos + 1) rhs) else "") + in + let derivation = + Derivation.build pos rhs derivation (Some comment) + in - end + follow1 tok derivation offset configs + + end else - (* This is a shift transition. Tack symbol in front of forest. *) + (* This is a shift transition. Tack symbol in front of forest. *) - let derivation = - Derivation.prepend rhs.(pos) derivation - in + let derivation = + Derivation.prepend rhs.(pos) derivation + in - follow1 tok derivation offset configs + follow1 tok derivation offset configs (* Symbolic execution is performed in the same manner as above. *) @@ -285,41 +285,41 @@ Misc.qiter (function (item, lookahead, offset) as config -> (* If the item we're looking at is the goal item and if - we have read all of the input symbols, stop. *) + we have read all of the input symbols, stop. *) if (Item.equal item stop) && lookahead && (offset = n) then - raise Done; + raise Done; (* Otherwise, explore the transitions out of this item. *) let prod, _nt, rhs, pos, length = Item.def item in (* Shift transition, followed only if the symbol matches - the symbol found in the input string. *) + the symbol found in the input string. *) if (pos < length) && (offset < n) && (Symbol.equal rhs.(pos) input.(offset)) then begin - let config' = (Item.import (prod, pos+1), lookahead, offset+1) in - enqueue (Some config) config' + let config' = (Item.import (prod, pos+1), lookahead, offset+1) in + enqueue (Some config) config' end; (* Epsilon transitions. *) if pos < length then - match rhs.(pos) with - | Symbol.N nt -> - 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 - in - Production.iternt nt (fun prod -> - let config' = (Item.import (prod, 0), lookahead', offset) in - enqueue (Some config) config' + match rhs.(pos) with + | Symbol.N nt -> + 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 + in + Production.iternt nt (fun prod -> + let config' = (Item.import (prod, 0), lookahead', offset) in + enqueue (Some config) config' ) - | Symbol.T _ -> - () + | Symbol.T _ -> + () ) queue; assert false @@ -343,46 +343,46 @@ try (* Construct a partial LR(1) automaton, looking for a conflict - in a state that corresponds to this node. Because Pager's - algorithm can merge two states as soon as one of them has a - conflict, we can't be too specific about the conflict that we - expect to find in the canonical automaton. So, we must supply - a set of conflict tokens and accept any kind of conflict that - involves one of them. *) + in a state that corresponds to this node. Because Pager's + algorithm can merge two states as soon as one of them has a + conflict, we can't be too specific about the conflict that we + expect to find in the canonical automaton. So, we must supply + a set of conflict tokens and accept any kind of conflict that + involves one of them. *) (* TEMPORARY with the new compatibility criterion, we can be - sure that every conflict token is indeed involved in a - conflict. Exploit that? Avoid focusing on a single token? *) + sure that every conflict token is indeed involved in a + conflict. Exploit that? Avoid focusing on a single token? *) let module P = Lr1partial.Run (struct - let tokens = toks - let goal = node + let tokens = toks + let goal = node end) in let closure = - Lr0.closure P.goal in + Lr0.closure P.goal in (* Determine what kind of conflict was found. *) let shift, reduce = Item.Map.fold (fun item toks (shift, reduce) -> - match Item.classify item with - | Item.Shift (Symbol.T tok, _) - when Terminal.equal tok P.token -> - shift + 1, reduce - | Item.Reduce _ - when TerminalSet.mem P.token toks -> - shift, reduce + 1 - | _ -> - shift, reduce + match Item.classify item with + | Item.Shift (Symbol.T tok, _) + when Terminal.equal tok P.token -> + shift + 1, reduce + | Item.Reduce _ + when TerminalSet.mem P.token toks -> + shift, reduce + 1 + | _ -> + shift, reduce ) closure (0, 0) in let kind = - if (shift > 0) && (reduce > 1) then - "shift/reduce/reduce" - else if (shift > 0) then - "shift/reduce" - else - "reduce/reduce" + if (shift > 0) && (reduce > 1) then + "shift/reduce/reduce" + else if (shift > 0) then + "shift/reduce" + else + "reduce/reduce" in (* Explain how the conflict state is reached. *) @@ -391,91 +391,91 @@ Printf.fprintf out "\n\ ** Conflict (%s) in state %d.\n\ - ** Token%s involved: %s\n%s\ - ** This state is reached from %s after reading:\n\n%s\n" + ** Token%s involved: %s\n%s\ + ** This state is reached from %s after reading:\n\n%s\n" kind (Lr1.number node) (if TerminalSet.cardinal toks > 1 then "s" else "") (TerminalSet.print toks) (if TerminalSet.cardinal toks > 1 then - Printf.sprintf "** The following explanations concentrate on token %s.\n" (Terminal.print P.token) + Printf.sprintf "** The following explanations concentrate on token %s.\n" (Terminal.print P.token) else "") (Nonterminal.print false (Item.startnt P.source)) (Symbol.printa P.path); (* Examine the items in that state, focusing on one particular - token. Out of the shift items, we explain just one -- this - seems enough. We explain each of the reduce items. *) + token. Out of the shift items, we explain just one -- this + seems enough. We explain each of the reduce items. *) (* First, build a mapping of items to derivations. *) let (_ : bool), derivations = - Item.Map.fold (fun item toks (still_looking_for_shift_item, derivations) -> - match Item.classify item with + Item.Map.fold (fun item toks (still_looking_for_shift_item, derivations) -> + match Item.classify item with - | Item.Shift (Symbol.T tok, _) - when still_looking_for_shift_item && (Terminal.equal tok P.token) -> + | Item.Shift (Symbol.T tok, _) + when still_looking_for_shift_item && (Terminal.equal tok P.token) -> - false, - let derivation = explain_shift_item P.source P.path item in - Item.Map.add item derivation derivations + false, + let derivation = explain_shift_item P.source P.path item in + Item.Map.add item derivation derivations - | Item.Reduce _ - when TerminalSet.mem P.token toks -> + | Item.Reduce _ + when TerminalSet.mem P.token toks -> - still_looking_for_shift_item, - let derivation = explain_reduce_item P.token P.source P.path item in - Item.Map.add item derivation derivations + still_looking_for_shift_item, + let derivation = explain_reduce_item P.token P.source P.path item in + Item.Map.add item derivation derivations - | _ -> + | _ -> - still_looking_for_shift_item, - derivations + still_looking_for_shift_item, + derivations ) closure (true, Item.Map.empty) in (* Factor out the common context among all derivations, so as to avoid - repeating it. This helps prevent derivation trees from drifting too - far away towards the right. It also helps produce sub-derivations + repeating it. This helps prevent derivation trees from drifting too + far away towards the right. It also helps produce sub-derivations that are quite compact. *) let context, derivations = - Derivation.factor derivations + Derivation.factor derivations in (* Display the common context. *) Printf.fprintf out - "\n** The derivations that appear below have the following common factor:\ - \n** (The question mark symbol (?) represents the spot where the derivations begin to differ.)\n\n"; + "\n** The derivations that appear below have the following common factor:\ + \n** (The question mark symbol (?) represents the spot where the derivations begin to differ.)\n\n"; Derivation.printc out context; (* Then, display the sub-derivations. *) Item.Map.iter (fun item derivation -> - Printf.fprintf out - "\n** In state %d, looking ahead at %s, " - (Lr1.number node) - (Terminal.print P.token); - - begin match Item.classify item with - | Item.Shift _ -> - Printf.fprintf out "shifting is permitted\n** because of the following sub-derivation:\n\n" - | Item.Reduce prod -> - Printf.fprintf out - "reducing production\n** %s\n** is permitted because of the following sub-derivation:\n\n" - (Production.print prod) - end; + Printf.fprintf out + "\n** In state %d, looking ahead at %s, " + (Lr1.number node) + (Terminal.print P.token); + + begin match Item.classify item with + | Item.Shift _ -> + Printf.fprintf out "shifting is permitted\n** because of the following sub-derivation:\n\n" + | Item.Reduce prod -> + Printf.fprintf out + "reducing production\n** %s\n** is permitted because of the following sub-derivation:\n\n" + (Production.print prod) + end; - Derivation.print out derivation + Derivation.print out derivation ) derivations; flush out with Lr1partial.Oops -> - + (* Ha ha! We were unable to explain this conflict. This could happen because the automaton was butchered by conflict resolution directives, or because [--lalr] was enabled and we have unexplainable LALR conflicts. @@ -485,8 +485,8 @@ Printf.fprintf out "\n\ ** Conflict (unexplainable) in state %d.\n\ - ** Token%s involved: %s\n\ - ** %s.\n%!" + ** Token%s involved: %s\n\ + ** %s.\n%!" (Lr1.number node) (if TerminalSet.cardinal toks > 1 then "s" else "") (TerminalSet.print toks) diff -Nru menhir-20151112.dfsg/src/coqBackend.ml menhir-20160808+dfsg/src/coqBackend.ml --- menhir-20151112.dfsg/src/coqBackend.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/coqBackend.ml 2016-08-08 19:19:04.000000000 +0000 @@ -21,8 +21,8 @@ match ty with | None -> raise Not_found (* fpottier: argh! *) | Some t -> match t with - | Stretch.Declared s -> s.Stretch.stretch_content - | Stretch.Inferred _ -> assert false (* We cannot infer coq types *) + | Stretch.Declared s -> s.Stretch.stretch_content + | Stretch.Inferred _ -> assert false (* We cannot infer coq types *) let is_final_state node = match Invariant.has_default_reduction node with @@ -85,24 +85,24 @@ if Front.grammar.UnparameterizedSyntax.parameters <> [] then Error.error [] "the Coq back-end does not support %%parameter." - (* Optimized because if we extract some constants to the right caml term, + (* Optimized because if we extract some constants to the right caml term, the ocaml inlining+constant unfolding replaces that by the actual constant *) let rec write_optimized_int31 f n = match n with | 0 -> fprintf f "Int31.On" | 1 -> fprintf f "Int31.In" | k when k land 1 = 0 -> - fprintf f "(twice "; - write_optimized_int31 f (n lsr 1); - fprintf f ")" + fprintf f "(twice "; + write_optimized_int31 f (n lsr 1); + fprintf f ")" | _ -> - fprintf f "(twice_plus_one "; - write_optimized_int31 f (n lsr 1); - fprintf f ")" + fprintf f "(twice_plus_one "; + write_optimized_int31 f (n lsr 1); + fprintf f ")" let write_inductive_alphabet f name constrs = fprintf f "Inductive %s' : Set :=" name; - List.iter (fprintf f "\n | %s") constrs; + List.iter (fprintf f "\n| %s") constrs; fprintf f ".\n"; fprintf f "Definition %s := %s'.\n\n" name name; if List.length constrs > 0 then @@ -111,15 +111,15 @@ fprintf f "Program Instance %sNum : Numbered %s :=\n" name name; fprintf f " { inj := fun x => match x return _ with "; iteri (fun k constr -> - fprintf f "| %s => " constr; - write_optimized_int31 f k; - fprintf f " "; - ); + fprintf f "| %s => " constr; + write_optimized_int31 f k; + fprintf f " "; + ); fprintf f "end;\n"; fprintf f " surj := (fun n => match n return _ with "; iteri (fprintf f "| %d => %s "); fprintf f "| _ => %s end)%%int31;\n" (List.hd constrs); - fprintf f " inj_bound := %d%%int31 }.\n" (List.length constrs); + fprintf f " inj_bound := %d%%int31 }.\n" (List.length constrs); end else begin @@ -145,7 +145,7 @@ fprintf f " match t with\n"; Terminal.iter (fun terminal -> if not (Terminal.pseudo terminal) then - fprintf f " | %s => %s%%type\n" + fprintf f " | %s => %s%%type\n" (print_term terminal) (try print_type (Terminal.ocamltype terminal) with Not_found -> "unit") ); @@ -154,15 +154,15 @@ fprintf f "Definition nonterminal_semantic_type (nt:nonterminal) : Type:=\n"; fprintf f " match nt with\n"; Nonterminal.iterx (fun nonterminal -> - fprintf f " | %s => %s%%type\n" - (print_nterm nonterminal) - (print_type (Nonterminal.ocamltype nonterminal))); + fprintf f " | %s => %s%%type\n" + (print_nterm nonterminal) + (print_type (Nonterminal.ocamltype nonterminal))); fprintf f " end.\n\n"; fprintf f "Definition symbol_semantic_type (s:symbol) : Type:=\n"; fprintf f " match s with\n"; - fprintf f " | T t => terminal_semantic_type t\n"; - fprintf f " | NT nt => nonterminal_semantic_type nt\n"; + fprintf f " | T t => terminal_semantic_type t\n"; + fprintf f " | NT nt => nonterminal_semantic_type nt\n"; fprintf f " end.\n\n" let write_productions f = @@ -182,15 +182,15 @@ fprintf f " in\n"; fprintf f " match p with\n"; Production.iterx (fun prod -> - fprintf f " | %s => box\n" (print_prod prod); - fprintf f " (%s, [%s])\n" + fprintf f " | %s => box\n" (print_prod prod); + fprintf f " (%s, [%s])\n" (print_nterm (Production.nt prod)) (String.concat "; " (List.map print_symbol (List.rev (Array.to_list (Production.rhs prod))))); if Production.length prod = 0 then - fprintf f " (\n" + fprintf f " (\n" else - fprintf f " (fun %s =>\n" + fprintf f " (fun %s =>\n" (String.concat " " (List.rev (Array.to_list (Production.identifiers prod)))); if Settings.coq_no_actions then fprintf f "()" @@ -210,7 +210,7 @@ fprintf f "Definition nullable_nterm (nt:nonterminal) : bool :=\n"; fprintf f " match nt with\n"; Nonterminal.iterx (fun nt -> - fprintf f " | %s => %b\n" + fprintf f " | %s => %b\n" (print_nterm nt) (Analysis.nullable nt)); fprintf f " end.\n\n"; @@ -219,7 +219,7 @@ fprintf f " match nt with\n"; Nonterminal.iterx (fun nt -> let firstSet = Analysis.first nt in - fprintf f " | %s => [" (print_nterm nt); + fprintf f " | %s => [" (print_nterm nt); let first = ref true in TerminalSet.iter (fun t -> if !first then first := false else fprintf f "; "; @@ -248,14 +248,14 @@ let write_init f = write_inductive_alphabet f "initstate" ( ProductionMap.fold (fun _prod node l -> - (print_init node)::l) Lr1.entry []); + (print_init node)::l) Lr1.entry []); fprintf f "Instance InitStateAlph : Alphabet initstate := _.\n\n" let write_start_nt f = fprintf f "Definition start_nt (init:initstate) : nonterminal :=\n"; fprintf f " match init with\n"; Lr1.fold_entry (fun _prod node startnt _t () -> - fprintf f " | %s => %s\n" (print_init node) (print_nterm startnt) + fprintf f " | %s => %s\n" (print_init node) (print_nterm startnt) ) (); fprintf f " end.\n\n" @@ -263,31 +263,31 @@ fprintf f "Definition action_table (state:state) : action :=\n"; fprintf f " match state with\n"; lr1_iter_nonfinal (fun node -> - fprintf f " | %s => " (print_st node); + fprintf f " | %s => " (print_st node); match Invariant.has_default_reduction node with | Some (prod, _) -> - fprintf f "Default_reduce_act %s\n" (print_prod prod) + fprintf f "Default_reduce_act %s\n" (print_prod prod) | None -> fprintf f "Lookahead_act (fun terminal:terminal =>\n"; - fprintf f " match terminal return lookahead_action terminal with\n"; + fprintf f " match terminal return lookahead_action terminal with\n"; let has_fail = ref false in Terminal.iter (fun t -> if not (Terminal.pseudo t) then begin try let target = SymbolMap.find (Symbol.T t) (Lr1.transitions node) in - fprintf f " | %s => Shift_act %s (eq_refl _)\n" (print_term t) (print_nis target) + fprintf f " | %s => Shift_act %s (eq_refl _)\n" (print_term t) (print_nis target) with Not_found -> try let prod = Misc.single (TerminalMap.find t (Lr1.reductions node)) in - fprintf f " | %s => Reduce_act %s\n" (print_term t) (print_prod prod) + fprintf f " | %s => Reduce_act %s\n" (print_term t) (print_prod prod) with Not_found -> has_fail := true end); if !has_fail then - fprintf f " | _ => Fail_act\n"; - fprintf f " end)\n" + fprintf f " | _ => Fail_act\n"; + fprintf f " end)\n" ); fprintf f " end.\n\n" @@ -299,11 +299,11 @@ Nonterminal.iterx (fun nt -> try let target = SymbolMap.find (Symbol.N nt) (Lr1.transitions node) in - fprintf f " | %s, %s => " (print_st node) (print_nterm nt); - if is_final_state target then fprintf f "None" - else fprintf f "Some (exist _ %s (eq_refl _))\n" (print_nis target) + fprintf f " | %s, %s => " (print_st node) (print_nterm nt); + if is_final_state target then fprintf f "None" + else fprintf f "Some (exist _ %s (eq_refl _))\n" (print_nis target) with Not_found -> has_none := true)); - if !has_none then fprintf f " | _, _ => None\n"; + if !has_none then fprintf f " | _, _ => None\n"; fprintf f " end.\n\n" let write_last_symb f = @@ -311,7 +311,7 @@ fprintf f " match noninitstate with\n"; lr1_iterx_nonfinal (fun node -> match Lr1.incoming_symbol node with - | Some s -> fprintf f " | %s => %s\n" (print_nis node) (print_symbol s) + | Some s -> fprintf f " | %s => %s\n" (print_nis node) (print_symbol s) | None -> assert false); fprintf f " end.\n\n" @@ -324,70 +324,97 @@ (Invariant.fold (fun l _ symb _ -> print_symbol symb::l) [] (Invariant.stack node))) in - fprintf f " | %s => [%s]\n" (print_nis node) s); + fprintf f " | %s => [%s]\n" (print_nis node) s); fprintf f " end.\n"; fprintf f "Extract Constant past_symb_of_non_init_state => \"fun _ -> assert false\".\n\n" + module NodeSetMap = Map.Make(Lr1.NodeSet) let write_past_states f = - fprintf f "Definition past_state_of_non_init_state (s:noninitstate) : list (state -> bool) :=\n"; - fprintf f " match s with\n"; + let get_stateset_id = + let memo = ref NodeSetMap.empty in + let next_id = ref 1 in + fun stateset -> + try NodeSetMap.find stateset !memo + with + | Not_found -> + let id = sprintf "state_set_%d" !next_id in + memo := NodeSetMap.add stateset id !memo; + incr next_id; + fprintf f "Definition %s (s:state) : bool :=\n" id; + fprintf f " match s with\n"; + fprintf f " "; + Lr1.NodeSet.iter (fun st -> fprintf f "| %s " (print_st st)) stateset; + fprintf f "=> true\n"; + fprintf f " | _ => false\n"; + fprintf f " end.\n"; + fprintf f "Extract Inlined Constant %s => \"assert false\".\n\n" id; + id + in + let b = Buffer.create 256 in + bprintf b "Definition past_state_of_non_init_state (s:noninitstate) : list (state -> bool) :=\n"; + bprintf b " match s with\n"; lr1_iterx_nonfinal (fun node -> let s = - String.concat ";\n " (Invariant.fold - (fun accu _ _ states -> - let b = Buffer.create 16 in - bprintf b "fun s:state =>\n"; - bprintf b " match s return bool with\n"; - bprintf b " "; - Lr1.NodeSet.iter - (fun st -> bprintf b "| %s " (print_st st)) states; - bprintf b "=> true\n"; - bprintf b " | _ => false\n"; - bprintf b " end"; - Buffer.contents b::accu) - [] (Invariant.stack node)) + String.concat "; " + (Invariant.fold (fun accu _ _ states -> get_stateset_id states::accu) + [] (Invariant.stack node)) in - fprintf f " | %s =>\n [ %s ]\n" (print_nis node) s); - fprintf f " end.\n\n"; + bprintf b " | %s => [ %s ]\n" (print_nis node) s); + bprintf b " end.\n"; + Buffer.output_buffer f b; fprintf f "Extract Constant past_state_of_non_init_state => \"fun _ -> assert false\".\n\n" + module TerminalSetMap = Map.Make(TerminalSet) let write_items f = if not Settings.coq_no_complete then begin - lr1_iter_nonfinal (fun node -> - fprintf f "Definition items_of_state_%d : list item :=\n" (Lr1.number node); - fprintf f " [ "; + let get_lookaheadset_id = + let memo = ref TerminalSetMap.empty in + let next_id = ref 1 in + fun lookaheadset -> + let lookaheadset = + if TerminalSet.mem Terminal.sharp lookaheadset then TerminalSet.universe + else lookaheadset + in + try TerminalSetMap.find lookaheadset !memo + with Not_found -> + let id = sprintf "lookahead_set_%d" !next_id in + memo := TerminalSetMap.add lookaheadset id !memo; + incr next_id; + fprintf f "Definition %s : list terminal :=\n [" id; + let first = ref true in + TerminalSet.iter (fun lookahead -> + if !first then first := false + else fprintf f "; "; + fprintf f "%s" (print_term lookahead) + ) lookaheadset; + fprintf f "].\nExtract Inlined Constant %s => \"assert false\".\n\n" id; + id + in + let b = Buffer.create 256 in + lr1_iter_nonfinal (fun node -> + bprintf b "Definition items_of_state_%d : list item :=\n" (Lr1.number node); + bprintf b " [ "; let first = ref true in Item.Map.iter (fun item lookaheads -> let prod, pos = Item.export item in - if not (Production.is_start prod) then begin - if !first then first := false - else fprintf f ";\n "; - fprintf f "{| prod_item := %s;\n" (print_prod prod); - fprintf f " dot_pos_item := %d;\n" pos; - fprintf f " lookaheads_item := ["; - let first = ref true in - let lookaheads = - if TerminalSet.mem Terminal.sharp lookaheads then TerminalSet.universe - else lookaheads - in - TerminalSet.iter (fun lookahead -> - if !first then first := false - else fprintf f "; "; - fprintf f "%s" (print_term lookahead) - ) lookaheads; - fprintf f "] |}" - end + if not (Production.is_start prod) then begin + if !first then first := false + else bprintf b ";\n "; + bprintf b "{| prod_item := %s; dot_pos_item := %d; lookaheads_item := %s |}" + (print_prod prod) pos (get_lookaheadset_id lookaheads); + end ) (Lr0.closure (Lr0.export (Lr1.state node))); - fprintf f " ].\n"; - fprintf f "Extract Inlined Constant items_of_state_%d => \"assert false\".\n\n" (Lr1.number node) + bprintf b " ].\n"; + bprintf b "Extract Inlined Constant items_of_state_%d => \"assert false\".\n\n" (Lr1.number node) ); + Buffer.output_buffer f b; - fprintf f "Definition items_of_state (s:state) : list item :=\n"; - fprintf f " match s with\n"; - lr1_iter_nonfinal (fun node -> - fprintf f " | %s => items_of_state_%d\n" (print_st node) (Lr1.number node)); - fprintf f " end.\n"; + fprintf f "Definition items_of_state (s:state) : list item :=\n"; + fprintf f " match s with\n"; + lr1_iter_nonfinal (fun node -> + fprintf f " | %s => items_of_state_%d\n" (print_st node) (Lr1.number node)); + fprintf f " end.\n"; end else fprintf f "Definition items_of_state (s:state): list item := [].\n"; @@ -428,34 +455,34 @@ end; Lr1.fold_entry (fun _prod node startnt _t () -> - let funName = Nonterminal.print true startnt in - fprintf f "Definition %s := Parser.parse safe Aut.%s.\n\n" - funName (print_init node); - - fprintf f "Theorem %s_correct iterator buffer:\n" funName; - fprintf f " match %s iterator buffer with\n" funName; - fprintf f " | Parser.Inter.Parsed_pr sem buffer_new =>\n"; - fprintf f " exists word,\n"; - fprintf f " buffer = Parser.Inter.app_str word buffer_new /\\\n"; - fprintf f " inhabited (Gram.parse_tree (%s) word sem)\n" (print_symbol (Symbol.N startnt)); - fprintf f " | _ => True\n"; - fprintf f " end.\n"; - fprintf f "Proof. apply Parser.parse_correct. Qed.\n\n"; + let funName = Nonterminal.print true startnt in + fprintf f "Definition %s := Parser.parse safe Aut.%s.\n\n" + funName (print_init node); + + fprintf f "Theorem %s_correct iterator buffer:\n" funName; + fprintf f " match %s iterator buffer with\n" funName; + fprintf f " | Parser.Inter.Parsed_pr sem buffer_new =>\n"; + fprintf f " exists word,\n"; + fprintf f " buffer = Parser.Inter.app_str word buffer_new /\\\n"; + fprintf f " inhabited (Gram.parse_tree (%s) word sem)\n" (print_symbol (Symbol.N startnt)); + fprintf f " | _ => True\n"; + fprintf f " end.\n"; + fprintf f "Proof. apply Parser.parse_correct. Qed.\n\n"; - if not Settings.coq_no_complete then - begin + if not Settings.coq_no_complete then + begin fprintf f "Theorem %s_complete (iterator:nat) word buffer_end (output:%s):\n" - funName (print_type (Nonterminal.ocamltype startnt)); + funName (print_type (Nonterminal.ocamltype startnt)); fprintf f " forall tree:Gram.parse_tree (%s) word output,\n" (print_symbol (Symbol.N startnt)); fprintf f " match %s iterator (Parser.Inter.app_str word buffer_end) with\n" funName; - fprintf f " | Parser.Inter.Fail_pr => False\n"; - fprintf f " | Parser.Inter.Parsed_pr output_res buffer_end_res =>\n"; - fprintf f " output_res = output /\\ buffer_end_res = buffer_end /\\\n"; - fprintf f " le (Gram.pt_size tree) iterator\n"; - fprintf f " | Parser.Inter.Timeout_pr => lt iterator (Gram.pt_size tree)\n"; + fprintf f " | Parser.Inter.Fail_pr => False\n"; + fprintf f " | Parser.Inter.Parsed_pr output_res buffer_end_res =>\n"; + fprintf f " output_res = output /\\ buffer_end_res = buffer_end /\\\n"; + fprintf f " le (Gram.pt_size tree) iterator\n"; + fprintf f " | Parser.Inter.Timeout_pr => lt iterator (Gram.pt_size tree)\n"; fprintf f " end.\n"; fprintf f "Proof. apply Parser.parse_complete with (init:=Aut.%s); exact complete. Qed.\n\n" (print_init node); - end + end ) () let write_all f = diff -Nru menhir-20151112.dfsg/src/cst.ml menhir-20160808+dfsg/src/cst.ml --- menhir-20151112.dfsg/src/cst.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/cst.ml 2016-08-08 19:19:04.000000000 +0000 @@ -24,22 +24,22 @@ Printf.bprintf b "%s" (Terminal.print tok) | CstNonTerminal (prod, csts) -> - + (* A node is denoted by a bracketed, whitespace-separated list, - whose head is a non-terminal symbol (followed with a colon) - and whose tail consists of the node's descendants. *) + whose head is a non-terminal symbol (followed with a colon) + and whose tail consists of the node's descendants. *) (* There is in fact some ambiguity in this notation, since we - only print the non-terminal symbol that forms the left-hand - side of production [prod], instead of the production itself. + only print the non-terminal symbol that forms the left-hand + side of production [prod], instead of the production itself. - This abuse makes things much more readable, and should be - acceptable for the moment. The cases where ambiguity actually - arises should be rare. *) + This abuse makes things much more readable, and should be + acceptable for the moment. The cases where ambiguity actually + arises should be rare. *) Printf.bprintf b "[%s:%a]" - (Nonterminal.print false (Production.nt prod)) - pcsts csts + (Nonterminal.print false (Production.nt prod)) + pcsts csts | CstError -> @@ -66,25 +66,25 @@ the same as that used by the above printer; the only difference is that the [Pprint] library is used to manage indentation. *) -open Pprint +open Pprint let rec build : cst -> document = function | CstTerminal tok -> text (Terminal.print tok) | CstNonTerminal (prod, csts) -> brackets ( - group ( - text (Nonterminal.print false (Production.nt prod)) ^^ - colon ^^ - group ( - nest 2 ( - Array.fold_left (fun doc cst -> - doc ^^ break1 ^^ build cst - ) empty csts - ) - ) ^^ - break0 - ) + group ( + text (Nonterminal.print false (Production.nt prod)) ^^ + colon ^^ + group ( + nest 2 ( + Array.fold_left (fun doc cst -> + doc ^^ break1 ^^ build cst + ) empty csts + ) + ) ^^ + break0 + ) ) | CstError -> text "error" diff -Nru menhir-20151112.dfsg/src/derivation.ml menhir-20160808+dfsg/src/derivation.ml --- menhir-20151112.dfsg/src/derivation.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/derivation.ml 2016-08-08 19:19:04.000000000 +0000 @@ -88,10 +88,10 @@ assert false | Symbol.N _ as symbol -> { - prefix = []; - focus = TRooted (symbol, forest); - suffix = array_to_list rhs (pos + 1) length; - comment = (match comment with None -> "" | Some comment -> comment) + prefix = []; + focus = TRooted (symbol, forest); + suffix = array_to_list rhs (pos + 1) length; + comment = (match comment with None -> "" | Some comment -> comment) } let prepend symbol forest = @@ -234,12 +234,12 @@ None | CRooted (symbol1, cforest1), TRooted (symbol2, forest2) -> if Symbol.equal symbol1 symbol2 then - let cforest, cforest1, forest2 = - common_forest cforest1 forest2 - in - Some (CRooted (symbol1, cforest), cforest1, forest2) + let cforest, cforest1, forest2 = + common_forest cforest1 forest2 + in + Some (CRooted (symbol1, cforest), cforest1, forest2) else - None + None and common_forest cforest1 forest2 : cforest * cforest * forest = match cforest1 with @@ -250,20 +250,20 @@ && Symbol.lequal forest1.suffix forest2.suffix && forest1.comment = forest2.comment then begin - match common_tree forest1.focus forest2.focus with - | None -> - CHole, cforest1, forest2 - | Some (ctree, csubforest1, subforest2) -> - let cforest = { - prefix = forest1.prefix; - focus = ctree; - suffix = forest1.suffix; - comment = forest1.comment - } in - CCons cforest, csubforest1, subforest2 + match common_tree forest1.focus forest2.focus with + | None -> + CHole, cforest1, forest2 + | Some (ctree, csubforest1, subforest2) -> + let cforest = { + prefix = forest1.prefix; + focus = ctree; + suffix = forest1.suffix; + comment = forest1.comment + } in + CCons cforest, csubforest1, subforest2 end else - CHole, cforest1, forest2 + CHole, cforest1, forest2 (* [factor] factors the maximal common forest context out of a nonempty family of forests. We assume that the family is represented as a map indexed by @@ -276,34 +276,34 @@ match accu with | None -> - (* First time through the loop, so [forest] is the first forest - that we examine. Punch it, so as to produce a maximal forest - context and a residual forest. *) + (* First time through the loop, so [forest] is the first forest + that we examine. Punch it, so as to produce a maximal forest + context and a residual forest. *) - let context, residual = punch_forest forest in - Some (context, Item.Map.singleton item residual) + let context, residual = punch_forest forest in + Some (context, Item.Map.singleton item residual) | Some (context, residuals) -> (* Another iteration through the loop. [context] and [residuals] are - the maximal common context and the residuals of the forests - examined so far. *) + the maximal common context and the residuals of the forests + examined so far. *) (* Combine the common context obtained so far with the forest at hand. - This yields a new, smaller common context, as well as residuals for - the previous common context and for the forest at hand. *) + This yields a new, smaller common context, as well as residuals for + the previous common context and for the forest at hand. *) + + let context, contextr, forestr = common_forest context forest in - let context, contextr, forestr = common_forest context forest in - (* The residual forests are now: (i) the residual forest [forestr]; - and (ii) the previous residual forests [residuals], each of which - must be placed with the residual context [contextr]. *) + and (ii) the previous residual forests [residuals], each of which + must be placed with the residual context [contextr]. *) let residuals = - Item.Map.add item forestr (Item.Map.map (fill_forest contextr) residuals) - in + Item.Map.add item forestr (Item.Map.map (fill_forest contextr) residuals) + in - Some (context, residuals) + Some (context, residuals) ) forests None with diff -Nru menhir-20151112.dfsg/src/dot.ml menhir-20160808+dfsg/src/dot.ml --- menhir-20151112.dfsg/src/dot.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/dot.ml 2016-08-08 19:19:04.000000000 +0000 @@ -52,23 +52,23 @@ "" | Some style -> let style = - match style with - | Solid -> - "solid" - | Dashed -> - "dashed" - | Dotted -> - "dotted" - | Bold -> - "bold" - | Invisible -> - "invis" - | Filled -> - "filled" - | Diagonals -> - "diagonals" - | Rounded -> - "rounded" + match style with + | Solid -> + "solid" + | Dashed -> + "dashed" + | Dotted -> + "dotted" + | Bold -> + "bold" + | Invisible -> + "invis" + | Filled -> + "filled" + | Diagonals -> + "diagonals" + | Rounded -> + "rounded" in sprintf ", style = %s" style @@ -77,7 +77,7 @@ "" | Some shape -> let shape = - match shape with + match shape with | Box -> "box" | Oval -> @@ -120,30 +120,30 @@ ) size; begin match orientation with | Portrait -> - fprintf f "orientation = portrait;\n" + fprintf f "orientation = portrait;\n" | Landscape -> - fprintf f "orientation = landscape;\n" + fprintf f "orientation = landscape;\n" end; begin match rankdir with | LeftToRight -> - fprintf f "rankdir = LR;\n" + fprintf f "rankdir = LR;\n" | TopToBottom -> - fprintf f "rankdir = TB;\n" + fprintf f "rankdir = TB;\n" end; begin match ratio with | Compress -> - fprintf f "ratio = compress;\n" + fprintf f "ratio = compress;\n" | Fill -> - fprintf f "ratio = fill;\n" + fprintf f "ratio = fill;\n" | Auto -> - fprintf f "ratio = auto;\n" + fprintf f "ratio = auto;\n" end; G.iter (fun ?shape ?style ~label vertex -> fprintf f "%s [ label=\"%s\"%s%s ] ;\n" - (G.name vertex) - label - (print_style style) + (G.name vertex) + label + (print_style style) (print_shape shape) ); @@ -152,12 +152,12 @@ ignore style; ignore label; G.successors (fun ?style ~label destination -> - fprintf f "%s %s %s [ label=\"%s\"%s ] ;\n" - (G.name source) - (if directed then "->" else "--") - (G.name destination) - label - (print_style style) + fprintf f "%s %s %s [ label=\"%s\"%s ] ;\n" + (G.name source) + (if directed then "->" else "--") + (G.name destination) + label + (print_style style) ) source ); diff -Nru menhir-20151112.dfsg/src/Driver.mli menhir-20160808+dfsg/src/Driver.mli --- menhir-20151112.dfsg/src/Driver.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Driver.mli 2016-08-08 19:19:04.000000000 +0000 @@ -2,5 +2,4 @@ which could be produced by either ocamlyacc or Menhir. *) val grammar : - (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> ConcreteSyntax.grammar - + (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Syntax.partial_grammar diff -Nru menhir-20151112.dfsg/src/Engine.ml menhir-20160808+dfsg/src/Engine.ml --- menhir-20151112.dfsg/src/Engine.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/Engine.ml 2016-08-08 19:19:04.000000000 +0000 @@ -83,7 +83,7 @@ let rec run env please_discard : semantic_value checkpoint = (* Log the fact that we just entered this state. *) - + if log then Log.state env.current; @@ -340,7 +340,7 @@ else begin (* The stack is nonempty. Pop a cell, updating the current state - with that found in the popped cell, and try again. *) + with that found in the popped cell, and try again. *) let env = { env with stack = next; @@ -360,7 +360,7 @@ (* [start s] begins the parsing process. *) let start (s : state) (initial : Lexing.position) : semantic_value checkpoint = - + (* Build an empty stack. This is a dummy cell, which is its own successor. Its [next] field WILL be accessed by [error_fail] if an error occurs and is propagated all the way until the stack is empty. Its [endp] field WILL diff -Nru menhir-20151112.dfsg/src/Engine.mli menhir-20160808+dfsg/src/Engine.mli --- menhir-20151112.dfsg/src/Engine.mli 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/Engine.mli 2016-08-08 19:19:04.000000000 +0000 @@ -18,5 +18,5 @@ module Make (T : TABLE) : ENGINE with type state = T.state and type token = T.token - and type semantic_value = T.semantic_value + and type semantic_value = T.semantic_value and type production = T.production diff -Nru menhir-20151112.dfsg/src/error.ml menhir-20160808+dfsg/src/error.ml --- menhir-20151112.dfsg/src/error.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/error.ml 2016-08-08 19:19:04.000000000 +0000 @@ -66,7 +66,7 @@ ref false let display continuation header positions format = - List.iter (fun position -> + List.iter (fun position -> fprintf stderr "%s:\n" (Positions.string_of_pos position) ) positions; Printf.kfprintf @@ -78,19 +78,19 @@ display (fun _ -> exit 1) "Error: " - positions format + positions format let signal positions format = display (fun _ -> errors := true) "Error: " - positions format + positions format let warning positions format = display (fun _ -> ()) "Warning: " - positions format + positions format let errors () = !errors diff -Nru menhir-20151112.dfsg/src/fancy-parser.mly menhir-20160808+dfsg/src/fancy-parser.mly --- menhir-20151112.dfsg/src/fancy-parser.mly 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/fancy-parser.mly 2016-08-08 19:19:04.000000000 +0000 @@ -10,7 +10,6 @@ %{ -open ConcreteSyntax open Syntax open Positions @@ -21,7 +20,7 @@ %token TOKEN TYPE LEFT RIGHT NONASSOC START PREC PUBLIC COLON BAR EOF EQUAL %token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER ON_ERROR_REDUCE -%token LID UID +%token LID UID %token HEADER %token OCAMLTYPE %token PERCENTPERCENT @@ -30,7 +29,7 @@ /* ------------------------------------------------------------------------- */ /* Start symbol. */ -%start grammar +%start grammar /* ------------------------------------------------------------------------- */ /* Priorities. */ @@ -53,17 +52,17 @@ grammar: ds = declaration* PERCENTPERCENT rs = rule* t = trailer - { - { - pg_filename = ""; (* filled in by the caller *) - pg_declarations = List.flatten ds; - pg_rules = rs @ ParserAux.rules(); - pg_trailer = t + { + { + pg_filename = ""; (* filled in by the caller *) + pg_declarations = List.flatten ds; + pg_rules = rs; + pg_trailer = t } } /* ------------------------------------------------------------------------- */ -/* A declaration is an %{ Objective Caml header %}, or a %token, %start, +/* A declaration is an %{ OCaml header %}, or a %token, %start, %type, %left, %right, or %nonassoc declaration. */ declaration: @@ -79,9 +78,9 @@ { match t with | None -> - List.map (Positions.map (fun nonterminal -> DStart nonterminal)) nts + List.map (Positions.map (fun nonterminal -> DStart nonterminal)) nts | Some t -> - Misc.mapd (fun ntloc -> + Misc.mapd (fun ntloc -> Positions.mapd (fun nt -> DStart nt, DType (t, ParameterVar ntloc)) ntloc) nts } @@ -97,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, @@ -171,11 +171,11 @@ COLON optional_bar branches = branches - { + { let public, inline = flags in { - pr_public_flag = public; - pr_inline_flag = inline; + pr_public_flag = public; + pr_inline_flag = inline; pr_nt = Positions.value symbol; pr_positions = [ Positions.position symbol ]; pr_parameters = List.map Positions.value params; @@ -223,13 +223,13 @@ is within bounds. *) let action : Syntax.identifier option array -> Action.t = action in let pr_action = action (ParserAux.producer_names producers) in - { - pr_producers; - pr_action; - pr_branch_prec_annotation = ParserAux.override pos oprec1 oprec2; - pr_branch_production_level = level; - pr_branch_position = pos - }) + { + pr_producers; + pr_action; + pr_branch_prec_annotation = ParserAux.override pos oprec1 oprec2; + pr_branch_production_level = level; + pr_branch_position = pos + }) productions } @@ -310,9 +310,13 @@ (* 3- *) | /* leading bar disallowed */ branches = branches - { let position = position (with_poss $startpos $endpos ()) in - let symbol = ParserAux.anonymous position branches in - ParameterVar (with_pos position symbol) } + { ParameterAnonymous (with_poss $startpos $endpos branches) } + (* 2016/05/18: we used to eliminate anonymous rules on the fly during + parsing. However, when an anonymous rule appears in a parameterized + definition, the fresh nonterminal symbol that is created should be + parameterized. This was not done, and is not easy to do on the fly, + as it requires inherited attributes (or a way of simulating them). + We now use explicit abstract syntax for anonymous rules. *) /* ------------------------------------------------------------------------- */ /* Formal or actual parameter lists are delimited with parentheses and @@ -344,4 +348,3 @@ { Some (Lazy.force p) } %% - diff -Nru menhir-20151112.dfsg/src/Fix.ml menhir-20160808+dfsg/src/Fix.ml --- menhir-20151112.dfsg/src/Fix.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Fix.ml 2016-08-08 19:19:04.000000000 +0000 @@ -197,16 +197,16 @@ assert (src.outgoing = []); let rec loop = function | [] -> - () + () | dst :: dsts -> - if dst.marked then - loop dsts (* skip duplicate elements *) - else begin - dst.marked <- true; - link src dst; - loop dsts; - dst.marked <- false - end + if dst.marked then + loop dsts (* skip duplicate elements *) + else begin + dst.marked <- true; + link src dst; + loop dsts; + dst.marked <- false + end in loop dsts @@ -296,7 +296,7 @@ (* [insert node] inserts [node] into the workset. [node] must have no successors. *) - val insert: node -> unit + val insert: node -> unit (* [repeat f] repeatedly applies [f] to a node extracted out of the workset, until the workset becomes empty. [f] is allowed to use @@ -304,7 +304,7 @@ val repeat: (node -> unit) -> unit (* That's it! *) -end +end = struct (* Initialize the workset. *) diff -Nru menhir-20151112.dfsg/src/Fix.mli menhir-20160808+dfsg/src/Fix.mli --- menhir-20151112.dfsg/src/Fix.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Fix.mli 2016-08-08 19:19:04.000000000 +0000 @@ -95,4 +95,3 @@ computation takes place, on demand, when [get] is applied. *) val lfp: equations -> valuation end - \ No newline at end of file diff -Nru menhir-20151112.dfsg/src/front.ml menhir-20160808+dfsg/src/front.ml --- menhir-20151112.dfsg/src/front.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/front.ml 2016-08-08 19:19:04.000000000 +0000 @@ -19,7 +19,7 @@ let lexbuf = Lexing.from_string contents in lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; let grammar = - { (Driver.grammar Lexer.main lexbuf) with ConcreteSyntax.pg_filename = filename } + { (Driver.grammar Lexer.main lexbuf) with Syntax.pg_filename = filename } in Error.file_contents := None; grammar @@ -31,7 +31,7 @@ (* Read all of the grammar files that are named on the command line. *) -let partial_grammars = +let partial_grammars = List.map load_partial_grammar Settings.filenames let () = @@ -39,9 +39,16 @@ (* ------------------------------------------------------------------------- *) +(* Eliminate anonymous rules. *) + +let partial_grammars = + List.map Anonymous.transform_partial_grammar partial_grammars + +(* ------------------------------------------------------------------------- *) + (* If several grammar files were specified, merge them. *) -let parameterized_grammar = +let parameterized_grammar = PartialGrammar.join_partial_grammars partial_grammars (* ------------------------------------------------------------------------- *) @@ -49,7 +56,7 @@ (* Expand away all applications of parameterized nonterminal symbols, so as to obtain a grammar without parameterized nonterminal symbols. *) -let grammar = +let grammar = ParameterizedGrammar.expand parameterized_grammar let () = @@ -139,17 +146,17 @@ let grammar = if Settings.inline then begin - let grammar, inlined = + let grammar, inlined = NonTerminalDefinitionInlining.inline grammar in if not Settings.infer && inlined && not skipping_parser_generation then Error.warning [] - "you are using the standard library and/or the %%inline keyword. We\n\ - recommend switching on --infer in order to avoid obscure type error messages."; + "you are using the standard library and/or the %%inline keyword. We\n\ + recommend switching on --infer in order to avoid obscure type error messages."; Time.tick "Inlining"; grammar end - else + else grammar (* ------------------------------------------------------------------------- *) @@ -164,4 +171,3 @@ exit 0 | Settings.PMNormal -> () - diff -Nru menhir-20151112.dfsg/src/grammarFunctor.ml menhir-20160808+dfsg/src/grammarFunctor.ml --- menhir-20151112.dfsg/src/grammarFunctor.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/grammarFunctor.ml 2016-08-08 19:19:04.000000000 +0000 @@ -42,14 +42,14 @@ let levelip id properties = lazy (use id), properties.tk_precedence - let leveli id = + let leveli id = let properties = try - StringMap.find id grammar.tokens + StringMap.find id grammar.tokens with Not_found -> - assert false (* well-formedness check has been performed earlier *) + assert false (* well-formedness check has been performed earlier *) in - levelip id properties + levelip id properties (* This function prints warnings about useless precedence declarations for terminal symbols (%left, %right, %nonassoc). It should be invoked @@ -58,12 +58,12 @@ let diagnostics () = StringMap.iter (fun id properties -> if not (StringSet.mem id !ever_useful) then - match properties.tk_precedence with - | UndefinedPrecedence -> - () - | PrecedenceLevel (_, _, pos1, pos2) -> - Error.grammar_warning (Positions.two pos1 pos2) - "the precedence level assigned to %s is never useful." id + match properties.tk_precedence with + | UndefinedPrecedence -> + () + | PrecedenceLevel (_, _, pos1, pos2) -> + Error.grammar_warning (Positions.two pos1 pos2) + "the precedence level assigned to %s is never useful." id ) grammar.tokens end @@ -88,7 +88,7 @@ let original_nonterminals = nonterminals grammar - + let start = List.length new_start_nonterminals @@ -193,9 +193,9 @@ let tokens = tokens grammar in match tokens with | [] when verbose -> - Error.error [] "no tokens have been declared." + Error.error [] "no tokens have been declared." | _ -> - Misc.index ("error" :: tokens @ [ "#" ]) + Misc.index ("error" :: tokens @ [ "#" ]) let print tok = name.(tok) @@ -215,23 +215,23 @@ let real t = error <> t && t <> sharp - let token_properties = + let token_properties = let not_so_dummy_properties = (* applicable to [error] and [#] *) { - tk_filename = "__primitives__"; - tk_precedence = UndefinedPrecedence; - tk_associativity = UndefinedAssoc; - tk_ocamltype = None; - tk_is_declared = true; - tk_position = Positions.dummy; + tk_filename = "__primitives__"; + tk_precedence = UndefinedPrecedence; + tk_associativity = UndefinedAssoc; + tk_ocamltype = None; + tk_is_declared = true; + tk_position = Positions.dummy; } in Array.init n (fun tok -> - try - StringMap.find name.(tok) grammar.tokens + try + StringMap.find name.(tok) grammar.tokens with Not_found -> - assert (tok = sharp || tok = error); - not_so_dummy_properties + assert (tok = sharp || tok = error); + not_so_dummy_properties ) let () = @@ -240,7 +240,7 @@ Printf.fprintf f "Grammar has %d terminal symbols.\n" (n - 2) ) - let precedence_level tok = + let precedence_level tok = TokPrecedence.levelip (print tok) token_properties.(tok) let associativity tok = @@ -363,7 +363,7 @@ module TerminalSet = struct - include CompressedBitSet + include CompressedBitSet let print toks = Misc.separated_iter_to_string Terminal.print " " (fun f -> iter f toks) @@ -405,13 +405,13 @@ let compare sym1 sym2 = match sym1, sym2 with | N nt1, N nt2 -> - Nonterminal.compare nt1 nt2 + Nonterminal.compare nt1 nt2 | T tok1, T tok2 -> - Terminal.compare tok1 tok2 + Terminal.compare tok1 tok2 | N _, T _ -> - 1 + 1 | T _, N _ -> - -1 + -1 let equal sym1 sym2 = compare sym1 sym2 = 0 @@ -419,24 +419,24 @@ let rec lequal syms1 syms2 = match syms1, syms2 with | [], [] -> - true + true | sym1 :: syms1, sym2 :: syms2 -> - equal sym1 sym2 && lequal syms1 syms2 + equal sym1 sym2 && lequal syms1 syms2 | _ :: _, [] | [], _ :: _ -> - false + false let print = function | N nt -> - Nonterminal.print false nt + Nonterminal.print false nt | T tok -> - Terminal.print tok + Terminal.print tok let nonterminal = function | T _ -> - false + false | N _ -> - true + true (* Printing an array of symbols. [offset] is the start offset -- we print everything to its right. [dot] is the dot offset -- we @@ -447,10 +447,10 @@ let length = Array.length symbols in for i = offset to length do if i = dot then - Buffer.add_string buffer ". "; + Buffer.add_string buffer ". "; if i < length then begin - Buffer.add_string buffer (print symbols.(i)); - Buffer.add_char buffer ' ' + Buffer.add_string buffer (print symbols.(i)); + Buffer.add_char buffer ' ' end done; Buffer.contents buffer @@ -469,9 +469,9 @@ T (Terminal.lookup name) with Not_found -> try - N (Nonterminal.lookup name) + N (Nonterminal.lookup name) with Not_found -> - assert false (* well-formedness check has been performed earlier *) + assert false (* well-formedness check has been performed earlier *) end @@ -575,10 +575,10 @@ NonterminalMap.add nt k startprods ) grammar.start_symbols (0, NonterminalMap.empty) - let prec_decl : symbol located option array = + let prec_decl : symbol located option array = Array.make n None - let production_level : branch_production_level array = + let production_level : branch_production_level array = (* The start productions should receive this dummy level, I suppose. We use a fresh mark, so a reduce/reduce conflict that involves a start production will not be solved. *) @@ -614,9 +614,9 @@ let k, k' = ntprods.(nt) in let rec loop accu prod = if prod < k' then - loop (f prod accu) (prod + 1) + loop (f prod accu) (prod + 1) else - accu + accu in loop accu k @@ -658,20 +658,20 @@ if is_start prod then match (rhs prod).(0) with | Symbol.N nt -> - Some nt + Some nt | Symbol.T _ -> - assert false + assert false else None let action prod = match actions.(prod) with | Some action -> - action + action | None -> - (* Start productions have no action. *) - assert (is_start prod); - assert false + (* Start productions have no action. *) + assert (is_start prod); + assert false let positions prod = positions.(prod) @@ -779,9 +779,9 @@ Array.fold_left (fun accu symbol -> match symbol with | Symbol.T tok -> - PRightmostToken tok + PRightmostToken tok | Symbol.N _ -> - accu + accu ) PNone (rhs prod) let combine e1 e2 = @@ -792,19 +792,19 @@ let oterminal = match prec_decl with | None -> - rightmost_terminal prod + rightmost_terminal prod | Some { value = terminal } -> - PPrecDecl terminal + PPrecDecl terminal in match oterminal with | PNone -> - fact1, UndefinedPrecedence + fact1, UndefinedPrecedence | PRightmostToken tok -> - let fact2, level = Terminal.precedence_level tok in - combine fact1 fact2, level + let fact2, level = Terminal.precedence_level tok in + combine fact1 fact2, level | PPrecDecl id -> - let fact2, level = TokPrecedence.leveli id in - combine fact1 fact2, level + let fact2, level = TokPrecedence.leveli id in + combine fact1 fact2, level end @@ -842,7 +842,7 @@ (* [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 @@ -896,7 +896,7 @@ S.terminal tok | Symbol.N nt -> (* Recursive call to the analysis, via [get]. *) - get nt + get nt (* Analysis of (a suffix of) a production [prod], starting at index [i]. *) @@ -1166,19 +1166,19 @@ Array.iteri (fun prod (nt1, rhs) -> (* Iterate over all terminal symbols [t2] in the right-hand side. *) Array.iteri (fun i symbol -> - match symbol with - | Symbol.N _ -> - () - | Symbol.T t2 -> + match symbol with + | Symbol.N _ -> + () + | Symbol.T t2 -> let nullable = NULLABLE.production prod (i+1) and first = FIRST.production prod (i+1) in - (* The FIRST set of the remainder of the right-hand side - contributes to the FOLLOW set of [t2]. *) - tfollow.(t2) <- TerminalSet.union first tfollow.(t2); - (* If the remainder of the right-hand side is nullable, - FOLLOW(nt1) contributes to FOLLOW(t2). *) - if nullable then - tfollow.(t2) <- TerminalSet.union (follow nt1) tfollow.(t2) + (* The FIRST set of the remainder of the right-hand side + contributes to the FOLLOW set of [t2]. *) + tfollow.(t2) <- TerminalSet.union first tfollow.(t2); + (* If the remainder of the right-hand side is nullable, + FOLLOW(nt1) contributes to FOLLOW(t2). *) + if nullable then + tfollow.(t2) <- TerminalSet.union (follow nt1) tfollow.(t2) ) rhs ) Production.table; @@ -1277,19 +1277,19 @@ let symbol = rhs.(i) in match symbol with | Symbol.T tok' -> - assert (Terminal.equal tok tok'); - EObvious + assert (Terminal.equal tok tok'); + EObvious | Symbol.N nt -> - if TerminalSet.mem tok (FIRST.nonterminal nt) then - EFirst (tok, nt) - else begin - assert (NULLABLE.nonterminal nt); - match loop (i + 1) with - | ENullable (symbols, e) -> - ENullable (symbol :: symbols, e) - | e -> - ENullable ([ symbol ], e) - end + if TerminalSet.mem tok (FIRST.nonterminal nt) then + EFirst (tok, nt) + else begin + assert (NULLABLE.nonterminal nt); + match loop (i + 1) with + | ENullable (symbols, e) -> + ENullable (symbol :: symbols, e) + | e -> + ENullable ([ symbol ], e) + end in loop i @@ -1298,14 +1298,14 @@ "" | EFirst (tok, nt) -> Printf.sprintf "%s can begin with %s" - (Nonterminal.print false nt) - (Terminal.print tok) + (Nonterminal.print false nt) + (Terminal.print tok) | ENullable (symbols, e) -> let e = convert e in Printf.sprintf "%scan vanish%s%s" - (Symbol.printl symbols) - (if e = "" then "" else " and ") - e + (Symbol.printl symbols) + (if e = "" then "" else " and ") + e (* ------------------------------------------------------------------------ *) (* Package the analysis results. *) @@ -1363,94 +1363,94 @@ type order = Lt | Gt | Eq | Ic - let precedence_order p1 p2 = + let precedence_order p1 p2 = match p1, p2 with - | UndefinedPrecedence, _ - | _, UndefinedPrecedence -> - Ic + | UndefinedPrecedence, _ + | _, UndefinedPrecedence -> + Ic | PrecedenceLevel (m1, l1, _, _), PrecedenceLevel (m2, l2, _, _) -> - if not (Mark.same m1 m2) then - Ic - else - if l1 > l2 then - Gt - else if l1 < l2 then - Lt - else - Eq + if not (Mark.same m1 m2) then + Ic + else + if l1 > l2 then + Gt + else if l1 < l2 then + Lt + else + Eq let production_order p1 p2 = match p1, p2 with | ProductionLevel (m1, l1), ProductionLevel (m2, l2) -> - if not (Mark.same m1 m2) then - Ic - else - if l1 > l2 then - Gt - else if l1 < l2 then - Lt - else - Eq + if not (Mark.same m1 m2) then + Ic + else + if l1 > l2 then + Gt + else if l1 < l2 then + Lt + else + Eq let shift_reduce tok prod = let fact1, tokp = Terminal.precedence_level tok and fact2, prodp = Production.precedence prod in match precedence_order tokp prodp with - + (* Our information is inconclusive. Drop [fact1] and [fact2], - that is, do not record that this information was useful. *) + that is, do not record that this information was useful. *) | Ic -> - DontKnow + DontKnow (* Our information is useful. Record that fact by evaluating - [fact1] and [fact2]. *) + [fact1] and [fact2]. *) | (Eq | Lt | Gt) as c -> - Lazy.force fact1; - Lazy.force fact2; - match c with - - | Ic -> - assert false (* already dispatched *) - - | Eq -> - begin - match Terminal.associativity tok with - | LeftAssoc -> ChooseReduce - | RightAssoc -> ChooseShift - | NonAssoc -> ChooseNeither - | _ -> assert false - (* If [tok]'s precedence level is defined, then - its associativity must be defined as well. *) - end + Lazy.force fact1; + Lazy.force fact2; + match c with + + | Ic -> + assert false (* already dispatched *) + + | Eq -> + begin + match Terminal.associativity tok with + | LeftAssoc -> ChooseReduce + | RightAssoc -> ChooseShift + | NonAssoc -> ChooseNeither + | _ -> assert false + (* If [tok]'s precedence level is defined, then + its associativity must be defined as well. *) + end - | Lt -> - ChooseReduce + | Lt -> + ChooseReduce - | Gt -> - ChooseShift + | Gt -> + ChooseShift let reduce_reduce prod1 prod2 = - let pl1 = Production.production_level.(prod1) + let pl1 = Production.production_level.(prod1) and pl2 = Production.production_level.(prod2) in match production_order pl1 pl2 with - | Lt -> - Some prod1 - | Gt -> - Some prod2 - | Eq -> + | Lt -> + Some prod1 + | Gt -> + Some prod2 + | Eq -> (* The order is strict except in the presence of parameterized non-terminals and/or inlining. Two productions can have the same precedence level if they originate, via macro-expansion or via inlining, from a single production in the source grammar. *) None - | Ic -> + | Ic -> None end - + (* This function prints warnings about useless precedence declarations for terminal symbols (%left, %right, %nonassoc) and productions (%prec). It should be invoked after only the automaton has been constructed. *) @@ -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-20151112.dfsg/src/grammarFunctor.mli menhir-20160808+dfsg/src/grammarFunctor.mli --- menhir-20151112.dfsg/src/grammarFunctor.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/grammarFunctor.mli 2016-08-08 19:19:04.000000000 +0000 @@ -53,12 +53,12 @@ The Boolean parameter tells whether the string representation should be normalized, that is, whether parentheses and commas should be eliminated. This is necessary if the string is intended - for use as a valid nonterminal name or as a valid Objective Caml + for use as a valid nonterminal name or as a valid OCaml identifier. *) val print: bool -> t -> string - (* This is the Objective Caml type associated with a nonterminal + (* This is the OCaml type associated with a nonterminal symbol. It is known only if a %type declaration was provided. This function is not applicable to the internally generated nonterminals. *) @@ -81,7 +81,7 @@ (* Iteration over all nonterminals, except the start nonterminals. *) val iterx: (t -> unit) -> unit - val foldx: (t -> 'a -> 'a) -> 'a -> 'a + val foldx: (t -> 'a -> 'a) -> 'a -> 'a (* Tabulation of a function over nonterminals. *) @@ -141,7 +141,7 @@ val print: t -> string - (* This is the Objective Caml type associated with a terminal + (* This is the OCaml type associated with a terminal symbol. It is known only if the %token declaration was accompanied with a type. *) @@ -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-20151112.dfsg/src/IL.mli menhir-20160808+dfsg/src/IL.mli --- menhir-20151112.dfsg/src/IL.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/IL.mli 2016-08-08 19:19:04.000000000 +0000 @@ -54,7 +54,7 @@ (* Constraint. *) typeconstraint: (typ * typ) option - } + } and typedefrhs = | TDefRecord of fielddef list @@ -72,7 +72,7 @@ (* Type of the field. *) fieldtype: typescheme - } + } and datadef = { @@ -86,11 +86,11 @@ [None] if this is an ordinary ADT. *) datatypeparams: typ list option; - } + } and typ = - - (* Textual Objective Caml type. *) + + (* Textual OCaml type. *) | TypTextual of Stretch.ocamltype (* Type variable, without its leading quote. Can also be "_". *) @@ -113,7 +113,7 @@ (* Body. *) body: typ; - } + } and valdef = { @@ -129,7 +129,7 @@ (* Value to which it is bound. *) valval: expr - } + } and expr = @@ -178,7 +178,7 @@ | ERecordAccess of expr * string | ERecordWrite of expr * string * expr - (* Textual Objective Caml code. *) + (* Textual OCaml code. *) | ETextual of Stretch.t (* Comments. *) @@ -197,7 +197,7 @@ (* Branch body. *) branchbody: expr; - } + } and pattern = diff -Nru menhir-20151112.dfsg/src/IncrementalEngine.ml menhir-20160808+dfsg/src/IncrementalEngine.ml --- menhir-20151112.dfsg/src/IncrementalEngine.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/IncrementalEngine.ml 2016-08-08 19:19:04.000000000 +0000 @@ -243,7 +243,7 @@ ['a symbol]. This type is useful in situations where the index ['a] is not statically known. *) - type xsymbol = + type xsymbol = | X : 'a symbol -> xsymbol end diff -Nru menhir-20151112.dfsg/src/infer.ml menhir-20160808+dfsg/src/infer.ml --- menhir-20151112.dfsg/src/infer.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/infer.ml 2016-08-08 19:19:04.000000000 +0000 @@ -10,14 +10,14 @@ (* The type variable associated with a nonterminal symbol. Its name begins with a prefix which ensures that it begins with a lowercase letter and - cannot clash with Objective Caml keywords. *) + cannot clash with OCaml keywords. *) let ntvar symbol = Printf.sprintf "tv_%s" (Misc.normalize symbol) (* The term variable associated with a nonterminal symbol. Its name begins with a prefix which ensures that it begins with a lowercase letter and - cannot clash with Objective Caml keywords. *) + cannot clash with OCaml keywords. *) let encode symbol = Printf.sprintf "xv_%s" (Misc.normalize symbol) @@ -67,24 +67,24 @@ let formals = List.fold_left (fun formals (symbol, id) -> let id, startp, endp, starto, endo = - id, - Printf.sprintf "_startpos_%s_" id, - Printf.sprintf "_endpos_%s_" id, - Printf.sprintf "_startofs_%s_" id, - Printf.sprintf "_endofs_%s_" id + id, + Printf.sprintf "_startpos_%s_" id, + Printf.sprintf "_endpos_%s_" id, + Printf.sprintf "_startofs_%s_" id, + Printf.sprintf "_endofs_%s_" id in let t = - try - let props = StringMap.find symbol grammar.tokens in - (* Symbol is a terminal. *) - match props.tk_ocamltype with - | None -> - tunit - | Some ocamltype -> - TypTextual ocamltype - with Not_found -> - (* Symbol is a nonterminal. *) - nttype grammar symbol + try + let props = StringMap.find symbol grammar.tokens in + (* Symbol is a terminal. *) + match props.tk_ocamltype with + | None -> + tunit + | Some ocamltype -> + TypTextual ocamltype + with Not_found -> + (* Symbol is a nonterminal. *) + nttype grammar symbol in PAnnot (PVar id, t) :: PAnnot (PVar startp, tposition) :: @@ -135,13 +135,13 @@ productions that derive from the standard library are reflected first, so that type errors are not reported in them. *) - let bindings1, bindings2 = + let bindings1, bindings2 = StringMap.fold (fun symbol rule (bindings1, bindings2) -> List.fold_left (fun (bindings1, bindings2) branch -> - if is_standard branch then - (PWildcard, actiondef grammar symbol branch) :: bindings1, bindings2 - else - bindings1, (PWildcard, actiondef grammar symbol branch) :: bindings2 + if is_standard branch then + (PWildcard, actiondef grammar symbol branch) :: bindings1, bindings2 + else + bindings1, (PWildcard, actiondef grammar symbol branch) :: bindings2 ) (bindings1, bindings2) rule.branches ) grammar.rules ([], []) in @@ -256,37 +256,37 @@ let lexbuf = Lexing.from_string output in let lines : line list = - try - Lexdep.main lexbuf - with Lexdep.Error msg -> - (* Echo the error message, followed with ocamldep's output. *) - Error.error [] "%s" (msg ^ output) + try + Lexdep.main lexbuf + with Lexdep.Error msg -> + (* Echo the error message, followed with ocamldep's output. *) + Error.error [] "%s" (msg ^ output) in (* Look for the line that concerns the [.cmo] target, and echo a - modified version of this line, where the [.cmo] target is - replaced with [.ml] and [.mli] targets, and where the dependency - over the [.cmi] file is dropped. - - In doing so, we assume that the user's [Makefile] supports - bytecode compilation, so that it makes sense to request [bar.cmo] - to be built, as opposed to [bar.cmx]. This is not optimal, but - will do. [camldep] exhibits the same behavior. *) + modified version of this line, where the [.cmo] target is + replaced with [.ml] and [.mli] targets, and where the dependency + over the [.cmi] file is dropped. + + In doing so, we assume that the user's [Makefile] supports + bytecode compilation, so that it makes sense to request [bar.cmo] + to be built, as opposed to [bar.cmx]. This is not optimal, but + will do. [camldep] exhibits the same behavior. *) (* TEMPORARY allow ocamldep to be called with flag -native. *) List.iter (fun ((_, target_filename), dependencies) -> - if Filename.check_suffix target_filename ".cmo" then - let dependencies = List.filter (fun (basename, _) -> - basename <> base - ) dependencies in - if List.length dependencies > 0 then begin - Printf.printf "%s.ml %s.mli:" base base; - List.iter (fun (_basename, filename) -> - Printf.printf " %s" filename - ) dependencies; - Printf.printf "\n%!" - end + if Filename.check_suffix target_filename ".cmo" then + let dependencies = List.filter (fun (basename, _) -> + basename <> base + ) dependencies in + if List.length dependencies > 0 then begin + Printf.printf "%s.ml %s.mli:" base base; + List.iter (fun (_basename, filename) -> + Printf.printf " %s" filename + ) dependencies; + Printf.printf "\n%!" + end ) lines end; @@ -336,17 +336,17 @@ let types = StringMap.fold (fun symbol _ types -> let ocamltype = - try - List.assoc (Misc.normalize symbol) env - with Not_found -> - assert false + try + List.assoc (Misc.normalize symbol) env + with Not_found -> + assert false in if StringMap.mem symbol grammar.types then - (* If there was a declared type, keep it. *) - types + (* If there was a declared type, keep it. *) + types else - (* Otherwise, insert the inferred type. *) - StringMap.add symbol ocamltype types + (* Otherwise, insert the inferred type. *) + StringMap.add symbol ocamltype types ) grammar.rules grammar.types in diff -Nru menhir-20151112.dfsg/src/infer.mli menhir-20160808+dfsg/src/infer.mli --- menhir-20151112.dfsg/src/infer.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/infer.mli 2016-08-08 19:19:04.000000000 +0000 @@ -10,7 +10,7 @@ val infer: UnparameterizedSyntax.grammar -> UnparameterizedSyntax.grammar (* [depend grammar] prints (on the standard output channel) the - Objective Caml dependencies induced by the semantic actions. + OCaml dependencies induced by the semantic actions. Then, it exits the program. *) val depend: UnparameterizedSyntax.grammar -> 'a diff -Nru menhir-20151112.dfsg/src/InfiniteArray.ml menhir-20160808+dfsg/src/InfiniteArray.ml --- menhir-20151112.dfsg/src/InfiniteArray.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/InfiniteArray.ml 2016-08-08 19:19:04.000000000 +0000 @@ -19,7 +19,7 @@ default: 'a; mutable table: 'a array; mutable extent: int; (* the index of the greatest [set] ever, plus one *) - } + } let default_size = 16384 (* must be non-zero *) @@ -28,7 +28,7 @@ default = x; table = Array.make default_size x; extent = 0; -} +} let rec new_length length i = if i < length then diff -Nru menhir-20151112.dfsg/src/inliner.ml menhir-20160808+dfsg/src/inliner.ml --- menhir-20151112.dfsg/src/inliner.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/inliner.ml 2016-08-08 19:19:04.000000000 +0000 @@ -42,36 +42,36 @@ () else try - let _, def = Hashtbl.find table id in + let _, def = Hashtbl.find table id in - (* This is a globally defined identifier. Increment its usage - count. If it was never visited, enqueue its definition for + (* This is a globally defined identifier. Increment its usage + count. If it was never visited, enqueue its definition for exploration. *) - let n = - try - StringMap.find id !usage - with Not_found -> - Queue.add def queue; - 0 - in - usage := StringMap.add id (n + 1) !usage + let n = + try + StringMap.find id !usage + with Not_found -> + Queue.add def queue; + 0 + in + usage := StringMap.add id (n + 1) !usage with Not_found -> - (* This identifier is not global. It is either local or a - reference to some external library, e.g. ocaml's standard - library. *) - () + (* This identifier is not global. It is either local or a + reference to some external library, e.g. ocaml's standard + library. *) + () in (* Look for occurrences of identifiers inside expressions. *) let o = object - inherit [ StringSet.t, unit ] Traverse.fold - inherit locals table - method! evar locals () id = - visit locals id + inherit [ StringSet.t, unit ] Traverse.fold + inherit locals table + method! evar locals () id = + visit locals id end in @@ -112,18 +112,18 @@ | EVar _ | EData (_, []) | ERecordAccess (EVar _, _) -> - true + true | EMagic e -> - is_simple_arg e + is_simple_arg e | _ -> - false + false in let is_simple_app = function | EApp (EVar _, actuals) -> - List.for_all is_simple_arg actuals + List.for_all is_simple_arg actuals | _ -> - false + false in (* Taking a fresh instance of a type scheme. Ugly. *) @@ -137,21 +137,21 @@ fun scheme -> let mapping = List.map fresh scheme.quantifiers in let rec sub typ = - match typ with - | TypTextual _ -> - typ - | TypVar v -> - begin try - TypVar (List.assoc v mapping) - with Not_found -> - typ - end - | TypApp (f, typs) -> - TypApp (f, List.map sub typs) - | TypTuple typs -> - TypTuple (List.map sub typs) - | TypArrow (typ1, typ2) -> - TypArrow (sub typ1, sub typ2) + match typ with + | TypTextual _ -> + typ + | TypVar v -> + begin try + TypVar (List.assoc v mapping) + with Not_found -> + typ + end + | TypApp (f, typs) -> + TypApp (f, List.map sub typs) + | TypTuple typs -> + TypTuple (List.map sub typs) + | TypArrow (typ1, typ2) -> + TypArrow (sub typ1, sub typ2) in sub scheme.body in @@ -161,17 +161,17 @@ let rec annotate formals body typ = match formals, typ with | [], _ -> - [], EAnnot (body, type2scheme typ) + [], EAnnot (body, type2scheme typ) | formal :: formals, TypArrow (targ, tres) -> - let formals, body = annotate formals body tres in - PAnnot (formal, targ) :: formals, body + let formals, body = annotate formals body tres in + PAnnot (formal, targ) :: formals, body | _ :: _, _ -> - (* Type annotation has insufficient arity. *) - assert false + (* Type annotation has insufficient arity. *) + assert false in (* The heart of the inliner: rewriting a function call to a [let] - expression. + expression. If there was a type annotation at the function definition site, it is dropped, provided [--infer] was enabled. Otherwise, it is @@ -188,11 +188,11 @@ | Some scheme when not Settings.infer -> - let formals, body = annotate formals body (instance scheme) in - mlet formals actuals body + let formals, body = annotate formals body (instance scheme) in + mlet formals actuals body | _ -> - mlet formals actuals body + mlet formals actuals body in (* Look for occurrences of identifiers inside expressions, branches, @@ -204,45 +204,45 @@ inherit [ StringSet.t ] Traverse.map as super inherit locals table method! eapp locals e actuals = - match e with - | EVar id when - (Hashtbl.mem table id) && (* a global identifier *) - (not (StringSet.mem id locals)) (* not hidden by a local identifier *) - -> + match e with + | EVar id when + (Hashtbl.mem table id) && (* a global identifier *) + (not (StringSet.mem id locals)) (* not hidden by a local identifier *) + -> - let _, def = Hashtbl.find table id in (* cannot fail, thanks to the above check *) + let _, def = Hashtbl.find table id in (* cannot fail, thanks to the above check *) - let formals, body, oscheme = - match def with - | { valval = EFun (formals, body) } -> - formals, body, None - | { valval = EAnnot (EFun (formals, body), scheme) } -> - formals, body, Some scheme - | { valval = _ } -> - (* The definition is not a function definition. This should not - happen in the kind of code that we generate. *) - assert false - in + let formals, body, oscheme = + match def with + | { valval = EFun (formals, body) } -> + formals, body, None + | { valval = EAnnot (EFun (formals, body), scheme) } -> + formals, body, Some scheme + | { valval = _ } -> + (* The definition is not a function definition. This should not + happen in the kind of code that we generate. *) + assert false + in - assert (StringMap.mem id usage); - if StringMap.find id usage = 1 || is_simple_app body then + assert (StringMap.mem id usage); + if StringMap.find id usage = 1 || is_simple_app body then - (* The definition can be inlined, with beta reduction. *) + (* The definition can be inlined, with beta reduction. *) - inline formals (self#exprs locals actuals) (EComment (id, self#expr locals body)) oscheme + inline formals (self#exprs locals actuals) (EComment (id, self#expr locals body)) oscheme - else begin + else begin - (* The definition cannot be inlined. *) + (* The definition cannot be inlined. *) - enqueue def; - super#eapp locals e actuals + enqueue def; + super#eapp locals e actuals - end + end - | _ -> - (* The thing in function position is not a reference to a global. *) - super#eapp locals e actuals + | _ -> + (* The thing in function position is not a reference to a global. *) + super#eapp locals e actuals end in @@ -264,7 +264,7 @@ Error.logC 1 (fun f -> Printf.fprintf f "%d functions before inlining, %d functions after inlining.\n" before (List.length valdefs)); - + Time.tick "Inlining"; valdefs diff -Nru menhir-20151112.dfsg/src/InspectionTableInterpreter.ml menhir-20160808+dfsg/src/InspectionTableInterpreter.ml --- menhir-20151112.dfsg/src/InspectionTableInterpreter.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/InspectionTableInterpreter.ml 2016-08-08 19:19:04.000000000 +0000 @@ -32,7 +32,7 @@ | T : 'a terminal -> 'a symbol | N : 'a nonterminal -> 'a symbol - type xsymbol = + type xsymbol = | X : 'a symbol -> xsymbol end diff -Nru menhir-20151112.dfsg/src/internalSyntax.mli menhir-20160808+dfsg/src/internalSyntax.mli --- menhir-20151112.dfsg/src/internalSyntax.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/internalSyntax.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -type grammar = - { - p_preludes : Stretch.t list; - p_postludes : Syntax.trailer list; - p_parameters : Stretch.t list; - p_start_symbols : Positions.t StringMap.t; - 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; - } diff -Nru menhir-20151112.dfsg/src/interpret.ml menhir-20160808+dfsg/src/interpret.ml --- menhir-20151112.dfsg/src/interpret.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/interpret.ml 2016-08-08 19:19:04.000000000 +0000 @@ -89,36 +89,36 @@ match !toks with | tok :: more -> - (* Take a token off the list, and return it. *) + (* Take a token off the list, and return it. *) - toks := more; - tok + toks := more; + tok | [] -> - (* The finite list has been exhausted. Here, two plausible behaviors - come to mind. + (* The finite list has been exhausted. Here, two plausible behaviors + come to mind. - The first behavior consists in raising an exception. In that case, - we are creating a finite stream, and it is up to the parser to not - read past its end. - - The second behavior consists in returning a designated token. In - that case, we are creating an infinite, eventually constant, - stream. - - The choice between these two behaviors is somewhat arbitrary; - furthermore, in the second case, the choice of the designated - token is arbitrary as well. Here, we adopt the second behavior if - and only if the grammar has an EOF token, and we use EOF as the - designated token. Again, this is arbitrary, and could be changed - in the future. *) - - match Terminal.eof with - | Some eof -> - eof - | None -> - raise EndOfStream + The first behavior consists in raising an exception. In that case, + we are creating a finite stream, and it is up to the parser to not + read past its end. + + The second behavior consists in returning a designated token. In + that case, we are creating an infinite, eventually constant, + stream. + + The choice between these two behaviors is somewhat arbitrary; + furthermore, in the second case, the choice of the designated + token is arbitrary as well. Here, we adopt the second behavior if + and only if the grammar has an EOF token, and we use EOF as the + designated token. Again, this is arbitrary, and could be changed + in the future. *) + + match Terminal.eof with + | Some eof -> + eof + | None -> + raise EndOfStream in @@ -172,30 +172,30 @@ begin try match MenhirLib.Convert.Simplified.traditional2revised - (ReferenceInterpreter.interpret Settings.trace nt) - (stream toks) + (ReferenceInterpreter.interpret Settings.trace nt) + (stream toks) with | Some cst -> - (* Success. *) + (* Success. *) - Printf.printf "ACCEPT"; - if Settings.interpret_show_cst then begin - print_newline(); - Cst.show stdout cst - end + Printf.printf "ACCEPT"; + if Settings.interpret_show_cst then begin + print_newline(); + Cst.show stdout cst + end | None -> - (* Parser failure. *) + (* Parser failure. *) - Printf.printf "REJECT" + Printf.printf "REJECT" with EndOfStream -> (* Lexer failure. *) - + Printf.printf "OVERSHOOT" end; @@ -424,9 +424,9 @@ while true do match read() with | None -> - exit 0 + exit 0 | Some sentence -> - interpret sentence + interpret sentence done (* --------------------------------------------------------------------------- *) @@ -665,7 +665,7 @@ and runs2 = List.map filter_run runs2 in let table1 = message_table false runs1 and table2 = message_table false runs2 in - + (* Check that the domain of [table1] is a subset of the domain of [table2]. *) table1 |> Lr1.NodeMap.iter (fun s ((poss1, _), _) -> if not (Lr1.NodeMap.mem s table2) then diff -Nru menhir-20151112.dfsg/src/invariant.ml menhir-20160808+dfsg/src/invariant.ml --- menhir-20151112.dfsg/src/invariant.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/invariant.ml 2016-08-08 19:19:04.000000000 +0000 @@ -88,20 +88,20 @@ equal v1 v2 | _, _ -> (* Because all heights are known ahead of time, we are able - to (and careful to) compare only vectors of equal length. *) + to (and careful to) compare only vectors of equal length. *) assert false let rec join v1 v2 = match v1, v2 with | [], [] -> - [] + [] | states1 :: v1, states2 :: v2 -> - Lr1.NodeSet.union states1 states2 :: - join v1 v2 + Lr1.NodeSet.union states1 states2 :: + join v1 v2 | _, _ -> (* Because all heights are known ahead of time, we are able - to (and careful to) compare only vectors of equal length. *) - assert false + to (and careful to) compare only vectors of equal length. *) + assert false let push v x = x :: v @@ -147,7 +147,7 @@ let push v x = match v with | Bottom -> - Bottom + Bottom | NonBottom v -> NonBottom (StateVector.push v x) @@ -156,7 +156,7 @@ | Bottom -> Bottom | NonBottom v -> - NonBottom (StateVector.truncate h v) + NonBottom (StateVector.truncate h v) let is_maximal _ = false @@ -183,31 +183,31 @@ match Lr1.incoming_symbol node with | None -> - assert (Lr1.predecessors node = []); + assert (Lr1.predecessors node = []); assert (stack_height node = 0); - (* If [node] is a start state, then the stack at [node] may be (in - fact, must be) the empty stack. *) + (* If [node] is a start state, then the stack at [node] may be (in + fact, must be) the empty stack. *) - empty + empty | Some _symbol -> - (* If [node] is not a start state, then include the contribution of - every incoming transition. We compute a join over all predecessors. - The contribution of one predecessor is the abstract value found at - this predecessor, extended with a new cell for this transition, and - truncated to the stack height at [node], so as to avoid obtaining a - vector that is longer than expected/necessary. *) - - let height = stack_height node in - - List.fold_left (fun v predecessor -> - join v - (truncate height - (push (get predecessor) (Lr1.NodeSet.singleton predecessor)) - ) - ) bottom (Lr1.predecessors node) + (* If [node] is not a start state, then include the contribution of + every incoming transition. We compute a join over all predecessors. + The contribution of one predecessor is the abstract value found at + this predecessor, extended with a new cell for this transition, and + truncated to the stack height at [node], so as to avoid obtaining a + vector that is longer than expected/necessary. *) + + let height = stack_height node in + + List.fold_left (fun v predecessor -> + join v + (truncate height + (push (get predecessor) (Lr1.NodeSet.singleton predecessor)) + ) + ) bottom (Lr1.predecessors node) ) @@ -232,10 +232,10 @@ TerminalMap.fold (fun _ prods accu -> let prod = Misc.single prods in let nodes = - try - ProductionMap.lookup prod accu - with Not_found -> - Lr1.NodeSet.empty + try + ProductionMap.lookup prod accu + with Not_found -> + Lr1.NodeSet.empty in ProductionMap.add prod (Lr1.NodeSet.add node nodes) accu ) (Lr1.reductions node) accu @@ -266,15 +266,15 @@ if Lr1.NodeSet.is_empty (production_where prod) then match Production.classify prod with | Some nt -> - incr count; - Error.grammar_warning - (Nonterminal.positions nt) - "symbol %s is never accepted." (Nonterminal.print false nt) + incr count; + Error.grammar_warning + (Nonterminal.positions nt) + "symbol %s is never accepted." (Nonterminal.print false nt) | None -> - incr count; - Error.grammar_warning - (Production.positions prod) - "production %sis never reduced." (Production.print prod) + incr count; + Error.grammar_warning + (Production.positions prod) + "production %sis never reduced." (Production.print prod) ); if !count > 0 then Error.grammar_warning [] @@ -293,9 +293,9 @@ let height = Production.length prod in Lr1.NodeSet.fold (fun node accu -> join accu - (truncate height - (NonBottom (stack_states node)) - ) + (truncate height + (NonBottom (stack_states node)) + ) ) nodes bottom ) @@ -362,23 +362,23 @@ Production.iter (fun prod -> match production_states prod with | Bottom -> - () + () | NonBottom v -> - share v + share v ) (* Enforce condition (2) above. *) let () = Nonterminal.iter (fun nt -> - let count = + let count = Lr1.targets (fun count _ _ -> - count + 1 + count + 1 ) 0 (Symbol.N nt) in if count > 1 then Lr1.targets (fun () sources _ -> - List.iter represent sources + List.iter represent sources ) () (Symbol.N nt) ) @@ -403,7 +403,7 @@ let v = stack_states node in List.iter (fun states -> if Lr1.NodeSet.cardinal states >= 2 && handlers states then - represents states + represents states ) v ) @@ -414,15 +414,15 @@ if Action.has_syntaxerror (Production.action prod) then match production_states prod with | Bottom -> - () + () | NonBottom v -> - let sites = production_where prod in - let length = Production.length prod in - if length = 0 then - Lr1.NodeSet.iter represent sites - else - let states = List.nth v (length - 1) in - represents states + let sites = production_where prod in + let length = Production.length prod in + if length = 0 then + Lr1.NodeSet.iter represent sites + else + let states = List.nth v (length - 1) in + represents states ) (* Define accessors. *) @@ -488,8 +488,8 @@ assert false | NonBottom v -> List.combine - (convert (Production.rhs prod)) - v + (convert (Production.rhs prod)) + v (* [gotostack nt] is the structure of the stack when a shift transition over nonterminal [nt] is about to be taken. It @@ -499,7 +499,7 @@ Nonterminal.tabulate (fun nt -> let sources = Lr1.targets (fun accu sources _ -> - List.fold_right Lr1.NodeSet.add sources accu + List.fold_right Lr1.NodeSet.add sources accu ) Lr1.NodeSet.empty (Symbol.N nt) in [ Symbol.N nt, sources ] @@ -553,44 +553,44 @@ match w with | [] -> - (* I believe that every stack description either is definite - (that is, ends with [TailEmpty]) or contains at least one - represented state. Thus, if we find an empty [w], this - means that the stack is definitely empty. *) + (* I believe that every stack description either is definite + (that is, ends with [TailEmpty]) or contains at least one + represented state. Thus, if we find an empty [w], this + means that the stack is definitely empty. *) Die | ((_, states) as cell) :: w -> - if representeds states then + if representeds states then - (* Here is a represented state. We will pop this - cell and no more. *) + (* Here is a represented state. We will pop this + cell and no more. *) - DownTo ([ cell ], Represented) + DownTo ([ cell ], Represented) - else if handlers states then begin + else if handlers states then begin - (* Here is an unrepresented state that can handle - errors. The cell must hold a singleton set of states, so - we know which state to jump to, even though it isn't - represented. *) + (* Here is an unrepresented state that can handle + errors. The cell must hold a singleton set of states, so + we know which state to jump to, even though it isn't + represented. *) - assert (Lr1.NodeSet.cardinal states = 1); - let state = Lr1.NodeSet.choose states in - DownTo ([ cell ], UnRepresented state) + assert (Lr1.NodeSet.cardinal states = 1); + let state = Lr1.NodeSet.choose states in + DownTo ([ cell ], UnRepresented state) - end - else + end + else - (* Here is an unrepresented state that does not handle - errors. Pop this cell and look further. *) + (* Here is an unrepresented state that does not handle + errors. Pop this cell and look further. *) - match rewind w with - | Die -> - Die - | DownTo (w, st) -> - DownTo (cell :: w, st) + match rewind w with + | Die -> + Die + | DownTo (w, st) -> + DownTo (cell :: w, st) in rewind w @@ -725,10 +725,10 @@ (* If the semantic action mentions [$startpos($i)], then the [i]-th symbol in the right-hand side must keep track of its start position. Similarly for end positions. *) - Array.iteri (fun i id' -> - if id = id' then + Array.iteri (fun i id' -> + if id = id' then record_ConVar true (rhs.(i), where) - ) ids + ) ids ) (Action.keywords action) ); (* end of loop on productions *) @@ -814,12 +814,12 @@ let nts : SymbolSet.t = Lr1.fold (fun nts node -> try - let prods = TerminalMap.lookup Terminal.error (Lr1.reductions node) in - let prod = Misc.single prods in - let nt = Production.nt prod in - SymbolSet.add (Symbol.N nt) nts + let prods = TerminalMap.lookup Terminal.error (Lr1.reductions node) in + let prod = Misc.single prods in + let nt = Production.nt prod in + SymbolSet.add (Symbol.N nt) nts with Not_found -> - nts + nts ) SymbolSet.empty in (* ... then compute the set of all target states of all transitions @@ -888,11 +888,11 @@ let reduction = ProductionMap.is_singleton (Lr1.invert (Lr1.reductions s)) in match reduction with | Some _ -> - if SymbolMap.purelynonterminal (Lr1.transitions s) + if SymbolMap.purelynonterminal (Lr1.transitions s) then reduction else None | None -> - reduction + reduction ) diff -Nru menhir-20151112.dfsg/src/invariant.mli menhir-20160808+dfsg/src/invariant.mli --- menhir-20151112.dfsg/src/invariant.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/invariant.mli 2016-08-08 19:19:04.000000000 +0000 @@ -23,7 +23,7 @@ (* [fold] folds over a word. At each cell, [f] is applied to the accumulator, to a Boolean flag that tells whether the cell holds a - state, to the set of possible states of the cell, and to the symbol + state, to the set of possible states of the cell, and to the symbol associated with the cell. The stack is visited from bottom to top. *) val fold: ('a -> bool -> Symbol.t -> Lr1.NodeSet.t -> 'a) -> 'a -> word -> 'a diff -Nru menhir-20151112.dfsg/src/item.ml menhir-20160808+dfsg/src/item.ml --- menhir-20151112.dfsg/src/item.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/item.ml 2016-08-08 19:19:04.000000000 +0000 @@ -103,7 +103,7 @@ type node = { (* Nodes are sequentially numbered so as to allow applying - Tarjan's algorithm (below). *) + Tarjan's algorithm (below). *) num: int; @@ -112,29 +112,29 @@ item: t; (* All of the epsilon transitions that leave a node have the - same behavior with respect to lookahead information. *) + same behavior with respect to lookahead information. *) (* The lookahead set transmitted along an epsilon transition is - either a constant, or the union of a constant and the lookahead - set at the source node. The former case corresponds to a source - item whose trailer is not nullable, the latter to a source item - whose trailer is nullable. *) + either a constant, or the union of a constant and the lookahead + set at the source node. The former case corresponds to a source + item whose trailer is not nullable, the latter to a source item + whose trailer is nullable. *) epsilon_constant: L.t; epsilon_transmits: bool; (* Each node carries pointers to its successors through - epsilon transitions. This field is never modified - once initialization is over. *) + epsilon transitions. This field is never modified + once initialization is over. *) mutable epsilon_transitions: node list; (* The following fields are transient, that is, only used - temporarily during graph traversals. Marks are used to - recognize which nodes have been traversed already. Lists - of predecessors are used to record which edges have been - traversed. Lookahead information is attached with each - node. *) + temporarily during graph traversals. Marks are used to + recognize which nodes have been traversed already. Lists + of predecessors are used to record which edges have been + traversed. Lookahead information is attached with each + node. *) mutable mark: Mark.t; mutable predecessors: node list; @@ -160,38 +160,38 @@ let length = Array.length rhs in mapping.(Production.p2i prod) <- Array.init (length+1) (fun pos -> - let item = import (prod, pos) in - let num = !count in - count := num + 1; - - (* The lookahead set transmitted through an epsilon - transition is the FIRST set of the remainder of - the source item, plus, if that is nullable, the - lookahead set of the source item. *) - - let constant, transmits = - if pos < length then - let nullable, first = Analysis.nullable_first_prod prod (pos + 1) in - L.constant first, nullable - else - (* No epsilon transitions leave this item. *) - L.empty, false - in - - { - num = num; - item = item; - epsilon_constant = constant; - epsilon_transmits = transmits; - epsilon_transitions = []; (* temporary placeholder *) - mark = Mark.none; - predecessors = []; - lookahead = L.empty; - } + let item = import (prod, pos) in + let num = !count in + count := num + 1; + + (* The lookahead set transmitted through an epsilon + transition is the FIRST set of the remainder of + the source item, plus, if that is nullable, the + lookahead set of the source item. *) + + let constant, transmits = + if pos < length then + let nullable, first = Analysis.nullable_first_prod prod (pos + 1) in + L.constant first, nullable + else + (* No epsilon transitions leave this item. *) + L.empty, false + in + + { + num = num; + item = item; + epsilon_constant = constant; + epsilon_transmits = transmits; + epsilon_transitions = []; (* temporary placeholder *) + mark = Mark.none; + predecessors = []; + lookahead = L.empty; + } ) ) - + (* At each node, compute transitions. *) let () = @@ -200,17 +200,17 @@ let length = Array.length rhs in Array.iteri (fun pos node -> - node.epsilon_transitions <- - if pos < length then - match rhs.(pos) with - | Symbol.N nt -> - Production.foldnt nt [] (fun prod nodes -> - (item2node (import (prod, 0))) :: nodes - ) - | Symbol.T _ -> - [] - else - [] + node.epsilon_transitions <- + if pos < length then + match rhs.(pos) with + | Symbol.N nt -> + Production.foldnt nt [] (fun prod nodes -> + (item2node (import (prod, 0))) :: nodes + ) + | Symbol.T _ -> + [] + else + [] ) mapping.(Production.p2i prod) ) @@ -249,12 +249,12 @@ let iter f = Array.iter (fun nodes -> - Array.iter f nodes + Array.iter f nodes ) mapping let successors f node = if node.epsilon_transmits then - List.iter f node.epsilon_transitions + List.iter f node.epsilon_transitions end @@ -275,17 +275,17 @@ let scc = T.scc node in match scc with | [] -> - () + () | [ node ] -> - (* This is a strongly connected component of one node. Check - whether it carries a self-loop. Forbidding self-loops is not - strictly required by the code that follows, but is consistent - with the fact that we forbid cycles of length greater than 1. *) - - P.successors (fun successor -> - if successor.num = node.num then - cycle scc + (* This is a strongly connected component of one node. Check + whether it carries a self-loop. Forbidding self-loops is not + strictly required by the code that follows, but is consistent + with the fact that we forbid cycles of length greater than 1. *) + + P.successors (fun successor -> + if successor.num = node.num then + cycle scc ) node | _ -> @@ -293,7 +293,7 @@ (* This is a strongly connected component of at least two elements. *) - cycle scc + cycle scc ) (* Closure computation. *) @@ -317,24 +317,24 @@ let rec visit father transmits toks node = if Mark.same node.mark this then begin - (* Node has been visited already. *) - node.lookahead <- L.union toks node.lookahead; - if transmits then - node.predecessors <- father :: node.predecessors + (* Node has been visited already. *) + node.lookahead <- L.union toks node.lookahead; + if transmits then + node.predecessors <- father :: node.predecessors end else begin - (* Node is new. *) - node.predecessors <- if transmits then [ father ] else []; - node.lookahead <- toks; - follow node + (* Node is new. *) + node.predecessors <- if transmits then [ father ] else []; + node.lookahead <- toks; + follow node end and follow node = node.mark <- this; nodes := node :: !nodes; List.iter - (visit node node.epsilon_transmits node.epsilon_constant) - node.epsilon_transitions + (visit node node.epsilon_transmits node.epsilon_constant) + node.epsilon_transitions in @@ -354,13 +354,13 @@ let rec walk node = if not (Mark.same node.mark this) then begin - (* Node is new. *) - node.mark <- this; - (* Explore all predecessors and merge their lookahead - sets into the current node's own lookahead set. *) - List.iter (fun predecessor -> - walk predecessor; - node.lookahead <- L.union predecessor.lookahead node.lookahead + (* Node is new. *) + node.mark <- this; + (* Explore all predecessors and merge their lookahead + sets into the current node's own lookahead set. *) + List.iter (fun predecessor -> + walk predecessor; + node.lookahead <- L.union predecessor.lookahead node.lookahead ) node.predecessors end in diff -Nru menhir-20151112.dfsg/src/lexdep.mll menhir-20160808+dfsg/src/lexdep.mll --- menhir-20151112.dfsg/src/lexdep.mll 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lexdep.mll 2016-08-08 19:19:04.000000000 +0000 @@ -10,8 +10,8 @@ let fail lexbuf = raise (Error (Printf.sprintf - "failed to make sense of ocamldep's output (character %d).\n" - lexbuf.lex_curr_p.pos_cnum) + "failed to make sense of ocamldep's output (character %d).\n" + lexbuf.lex_curr_p.pos_cnum) ) } diff -Nru menhir-20151112.dfsg/src/lexer.mll menhir-20160808+dfsg/src/lexer.mll --- menhir-20151112.dfsg/src/lexer.mll 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lexer.mll 2016-08-08 19:19:04.000000000 +0000 @@ -217,7 +217,7 @@ (* Creates a stretch. *) -let mk_stretch pos1 pos2 parenthesize monsters = +let mk_stretch pos1 pos2 parenthesize monsters = (* Read the specified chunk of the file. *) let ofs1 = pos1.pos_cnum and ofs2 = pos2.pos_cnum in @@ -253,7 +253,7 @@ (* ------------------------------------------------------------------------ *) -(* Objective Caml's reserved words. *) +(* OCaml's reserved words. *) let reserved = let table = Hashtbl.create 149 in @@ -333,7 +333,7 @@ let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '0'-'9'] (* '\'' forbidden *) -let poskeyword = +let poskeyword = '$' (("symbolstart" | "start" | "end") as where) (("pos" | "ofs") as flavor) @@ -404,9 +404,9 @@ { PLUS } | (lowercase identchar *) as id { if Hashtbl.mem reserved id then - error2 lexbuf "this is an Objective Caml reserved word." + error2 lexbuf "this is an OCaml reserved word." else - LID (with_pos (cpos lexbuf) id) + LID (with_pos (cpos lexbuf) id) } | (uppercase identchar *) as id { UID (with_pos (cpos lexbuf) id) } @@ -433,11 +433,11 @@ let openingpos = lexeme_end_p lexbuf in let closingpos, monsters = action false openingpos [] lexbuf in ACTION ( - fun (producers : string option array) -> + fun (producers : string option array) -> List.iter (fun monster -> monster.check producers) monsters; - let stretch = mk_stretch openingpos closingpos true monsters in - Action.from_stretch stretch - ) + let stretch = mk_stretch openingpos closingpos true monsters in + Action.from_stretch stretch + ) ) } | eof { EOF } @@ -475,7 +475,7 @@ | newline { new_line lexbuf; ocamltype openingpos lexbuf } | eof - { error1 openingpos "unterminated Objective Caml type." } + { error1 openingpos "unterminated OCaml type." } | _ { ocamltype openingpos lexbuf } @@ -494,11 +494,11 @@ { match percent, delimiter with | true, "%}" | false, "}" -> - (* This is the delimiter we were instructed to look for. *) - lexeme_start_p lexbuf, monsters + (* This is the delimiter we were instructed to look for. *) + lexeme_start_p lexbuf, monsters | _, _ -> - (* This is not it. *) - error1 openingpos "unbalanced opening brace." + (* This is not it. *) + error1 openingpos "unbalanced opening brace." } | '(' { let _, monsters = parentheses (lexeme_end_p lexbuf) monsters lexbuf in @@ -588,7 +588,7 @@ | newline { new_line lexbuf; ocamlcomment openingpos lexbuf } | eof - { error1 openingpos "unterminated Objective Caml comment." } + { error1 openingpos "unterminated OCaml comment." } | _ { ocamlcomment openingpos lexbuf } @@ -597,7 +597,7 @@ (* Skip O'Caml strings. *) and string openingpos = parse -| '"' +| '"' { () } | '\\' newline | newline @@ -606,8 +606,8 @@ (* Upon finding a backslash, skip the character that follows, unless it is a newline. Pretty crude, but should work. *) { string openingpos lexbuf } -| eof - { error1 openingpos "unterminated Objective Caml string." } +| eof + { error1 openingpos "unterminated OCaml string." } | _ { string openingpos lexbuf } @@ -625,7 +625,7 @@ | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" | "" - { () } + { () } (* ------------------------------------------------------------------------ *) diff -Nru menhir-20151112.dfsg/src/listMonad.ml menhir-20160808+dfsg/src/listMonad.ml --- menhir-20151112.dfsg/src/listMonad.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/listMonad.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,31 +1,31 @@ type 'a m = 'a list -let return x = - [ x ] +let return x = + [ x ] -let bind l f = +let bind l f = List.flatten (List.map f l) -let ( >>= ) l f = +let ( >>= ) l f = bind l f -(* +(* 1. (return x) >>= f == f x - bind [ x ] f - = List.flatten (List.map f [ x ]) - = f x + bind [ x ] f + = List.flatten (List.map f [ x ]) + = f x 2. m >>= return == m - bind l return + bind l return = List.flatten (List.map (fun x -> [ x ]) (x1::x2::..::xn)) - = List.flatten ([x1]::...::[xn]) + = List.flatten ([x1]::...::[xn]) = x1::...::xn = l 3. (m >>= f) >>= g == m >>= (\x -> f x >>= g) - + bind (bind l f) g = List.flatten (List.map g (List.flatten (List.map f (x1::...::xn)))) = List.flatten (List.map g (f x1 :: f x2 :: ... :: f xn)) diff -Nru menhir-20151112.dfsg/src/lr0.ml menhir-20160808+dfsg/src/lr0.ml --- menhir-20151112.dfsg/src/lr0.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lr0.ml 2016-08-08 19:19:04.000000000 +0000 @@ -26,7 +26,7 @@ and vars = CompressedBitSet.union vars1 vars2 in if toks2 == toks && vars2 == vars then s2 - else + else (toks, vars) let variable (var : int) : t = @@ -69,15 +69,15 @@ Item.Map.fold (fun item toks transitions -> match Item.classify item with | Item.Shift (symbol, item') -> - let items : 'a Item.Map.t = - try - SymbolMap.find symbol transitions - with Not_found -> - Item.Map.empty - in - SymbolMap.add symbol (Item.Map.add item' toks items) transitions + let items : 'a Item.Map.t = + try + SymbolMap.find symbol transitions + with Not_found -> + Item.Map.empty + in + SymbolMap.add symbol (Item.Map.add item' toks items) transitions | Item.Reduce _ -> - transitions + transitions ) state SymbolMap.empty (* ------------------------------------------------------------------------ *) @@ -90,9 +90,9 @@ Item.Map.fold (fun item toks accu -> match Item.classify item with | Item.Reduce prod -> - (toks, prod) :: accu + (toks, prod) :: accu | Item.Shift _ -> - accu + accu ) state [] (* ------------------------------------------------------------------------ *) @@ -162,7 +162,7 @@ let (_ : int), (symbolic_state : SymbolicClosure.state) = Item.Set.fold (fun item (i, symbolic_state) -> - i+1, Item.Map.add item (SymbolicLookahead.variable i) symbolic_state + i+1, Item.Map.add item (SymbolicLookahead.variable i) symbolic_state ) state (0, Item.Map.empty) in (* Compute the symbolic closure. *) @@ -180,10 +180,10 @@ InfiniteArray.set _transitions k (SymbolMap.mapi (fun symbol symbolic_state -> let (k : node) = explore (Some symbol) (Item.Map.domain symbolic_state) in let lookahead : SymbolicLookahead.t array = - Array.make (Item.Map.cardinal symbolic_state) SymbolicLookahead.empty in + Array.make (Item.Map.cardinal symbolic_state) SymbolicLookahead.empty in let (_ : int) = Item.Map.fold (fun _ s i -> - lookahead.(i) <- s; - i+1 + lookahead.(i) <- s; + i+1 ) symbolic_state 0 in ((k, lookahead) : symbolic_transition_target) ) (transitions closure)); @@ -413,34 +413,34 @@ let toksr1i = toksr1.(i) and toksr2i = toksr2.(i) in let rec loopj j = - if j = i then - true - else - let toksr1j = toksr1.(j) - and toksr2j = toksr2.(j) in - - (* The two states are compatible at (i, j) if every conflict - token in the merged state already was a conflict token in - one of the two original states. This could be written as - follows: + if j = i then + true + else + let toksr1j = toksr1.(j) + and toksr2j = toksr2.(j) in + + (* The two states are compatible at (i, j) if every conflict + token in the merged state already was a conflict token in + one of the two original states. This could be written as + follows: TerminalSet.subset - (TerminalSet.inter (TerminalSet.union toksr1i toksr2i) (TerminalSet.union toksr1j toksr2j)) - (TerminalSet.union (TerminalSet.inter toksr1i toksr1j) (TerminalSet.inter toksr2i toksr2j)) + (TerminalSet.inter (TerminalSet.union toksr1i toksr2i) (TerminalSet.union toksr1j toksr2j)) + (TerminalSet.union (TerminalSet.inter toksr1i toksr1j) (TerminalSet.inter toksr2i toksr2j)) - but is easily seen (on paper) to be equivalent to: + but is easily seen (on paper) to be equivalent to: *) - TerminalSet.subset - (TerminalSet.inter toksr2i toksr1j) - (TerminalSet.union toksr1i toksr2j) - && - TerminalSet.subset - (TerminalSet.inter toksr1i toksr2j) - (TerminalSet.union toksr2i toksr1j) - && - loopj (j+1) + TerminalSet.subset + (TerminalSet.inter toksr2i toksr1j) + (TerminalSet.union toksr1i toksr2j) + && + TerminalSet.subset + (TerminalSet.inter toksr1i toksr2j) + (TerminalSet.union toksr2i toksr1j) + && + loopj (j+1) in loopj 0 && loopi (i+1) in @@ -478,14 +478,14 @@ let toks1 = toksr1.(i) and toks2 = toksr2.(i) in begin - if TerminalSet.mem Terminal.sharp toks1 && TerminalSet.is_singleton toks1 then - (* "#" is alone in one set: it must be a member of the other set. *) - TerminalSet.mem Terminal.sharp toks2 - else if TerminalSet.mem Terminal.sharp toks2 && TerminalSet.is_singleton toks2 then - (* Symmetric condition. *) - TerminalSet.mem Terminal.sharp toks1 - else - true + if TerminalSet.mem Terminal.sharp toks1 && TerminalSet.is_singleton toks1 then + (* "#" is alone in one set: it must be a member of the other set. *) + TerminalSet.mem Terminal.sharp toks2 + else if TerminalSet.mem Terminal.sharp toks2 && TerminalSet.is_singleton toks2 then + (* Symmetric condition. *) + TerminalSet.mem Terminal.sharp toks1 + else + true end && loop (i+1) in @@ -529,14 +529,14 @@ let toks1 = toksr1.(i) and toks2 = toksr2.(i) in begin - if TerminalSet.mem Terminal.error toks1 then - (* [error] is a member of one set: it must be a member of the other set. *) - TerminalSet.mem Terminal.error toks2 - else if TerminalSet.mem Terminal.error toks2 then - (* Symmetric condition. *) - TerminalSet.mem Terminal.error toks1 - else - true + if TerminalSet.mem Terminal.error toks1 then + (* [error] is a member of one set: it must be a member of the other set. *) + TerminalSet.mem Terminal.error toks2 + else if TerminalSet.mem Terminal.error toks2 then + (* Symmetric condition. *) + TerminalSet.mem Terminal.error toks1 + else + true end && loop (i+1) in diff -Nru menhir-20151112.dfsg/src/lr0.mli menhir-20160808+dfsg/src/lr0.mli --- menhir-20151112.dfsg/src/lr0.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lr0.mli 2016-08-08 19:19:04.000000000 +0000 @@ -58,7 +58,7 @@ (* One can create an LR(1) start state out of an LR(0) start node. *) - + val start: node -> lr1state (* Information about the transitions and reductions at a state. *) diff -Nru menhir-20151112.dfsg/src/lr1.ml menhir-20160808+dfsg/src/lr1.ml --- menhir-20151112.dfsg/src/lr1.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lr1.ml 2016-08-08 19:19:04.000000000 +0000 @@ -120,40 +120,40 @@ (* 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. + 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); + 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. + 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. *) @@ -280,29 +280,29 @@ | Settings.ModeCanonical -> (* In a canonical automaton, two states can be merged only if they - are identical. *) + are identical. *) - List.iter (fun node -> - if Lr0.subsume target node.state && - Lr0.subsume node.state target then - raise (Subsumed node) - ) similar + List.iter (fun node -> + if Lr0.subsume target node.state && + Lr0.subsume node.state target then + raise (Subsumed node) + ) similar | Settings.ModeInclusionOnly | Settings.ModePager -> (* A more aggressive approach is to take subsumption into account: - if the new candidate state is a subset of an existing state, - then no new node needs to be created. Furthermore, the existing - state does not need to be enlarged. *) + if the new candidate state is a subset of an existing state, + then no new node needs to be created. Furthermore, the existing + state does not need to be enlarged. *) (* 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 + List.iter (fun node -> + if Lr0.subsume target node.state && + Lr0.error_compatible target node.state then + raise (Subsumed node) + ) similar | Settings.ModeLALR -> () @@ -325,21 +325,21 @@ (* 20110124: require error compatibility in addition to the existing compatibility criteria. *) - 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 + 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 | Settings.ModeLALR -> (* In LALR mode, as soon as there is one similar state -- i.e. one state that shares the same LR(0) core -- we merge the new state into the existing one. *) - List.iter (fun node -> - raise (Compatible node) - ) similar + List.iter (fun node -> + raise (Compatible node) + ) similar end; @@ -361,8 +361,8 @@ | 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. *) + 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" node true; @@ -477,13 +477,13 @@ (* 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 + 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 @@ -493,148 +493,148 @@ of. *) let reductions = - List.fold_left (fun reductions (toks, prod) -> - TerminalSet.fold (addl prod) toks 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. *) + 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 + 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. *) + (* 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 + 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. *) + (* 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 + match Precedence.shift_reduce tok prod with - | Precedence.ChooseShift -> + | Precedence.ChooseShift -> - (* Suppress the reduce action. *) + (* Suppress the reduce action. *) - incr silently_solved; - reductions + incr silently_solved; + reductions - | Precedence.ChooseReduce -> + | 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). *) + (* 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 + incr silently_solved; + node.transitions <- SymbolMap.remove (Symbol.T tok) node.transitions; + TerminalMap.add tok prods reductions - | Precedence.ChooseNeither -> + | Precedence.ChooseNeither -> - (* Suppress the reduce action and the shift transition. *) + (* 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 + incr silently_solved; + node.transitions <- SymbolMap.remove (Symbol.T tok) node.transitions; + node.forbid_default_reduction <- true; + reductions - | Precedence.DontKnow -> + | Precedence.DontKnow -> - (* Priorities don't allow concluding. Record the - existence of a shift/reduce conflict. *) + (* 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 + node.conflict_tokens <- Grammar.TerminalSet.add tok node.conflict_tokens; + has_shift_reduce := true; + TerminalMap.add tok prods reductions - end + end - | _prod1 :: _prod2 :: _ -> + | _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. *) + (* 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 + let choices = List.map (Precedence.shift_reduce tok) prods in - if List.for_all (fun choice -> - match choice with - | Precedence.ChooseShift -> true - | _ -> false + if List.for_all (fun choice -> + match choice with + | Precedence.ChooseShift -> true + | _ -> false ) choices then begin - (* Suppress the reduce action. *) + (* Suppress the reduce action. *) - silently_solved := !silently_solved + List.length prods; - reductions + silently_solved := !silently_solved + List.length prods; + reductions - end - else if List.for_all (fun choice -> - match choice with - | Precedence.ChooseNeither -> true - | _ -> false + 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. *) + (* 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. *) + 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 + node.conflict_tokens <- Grammar.TerminalSet.add tok node.conflict_tokens; + has_reduce_reduce := true - in - TerminalMap.add tok prods reductions + 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 + 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 @@ -643,12 +643,12 @@ edges that carry distinct symbols. *) SymbolMap.iter (fun symbol son -> - son.predecessors <- node :: son.predecessors; - visit (Some symbol) son + son.predecessors <- node :: son.predecessors; + visit (Some symbol) son ) node.transitions end in - + ProductionMap.iter (fun _ node -> visit None node) entry let nodes = @@ -700,11 +700,11 @@ | Some _ -> f accu node) let iterx f = - iter (fun node -> - match incoming_symbol node with - | None -> () + iter (fun node -> + match incoming_symbol node with + | None -> () | Some _ -> f node) - + (* -------------------------------------------------------------------------- *) (* Our output channel. *) @@ -829,13 +829,13 @@ let prod = Misc.single prods in let toks = try - ProductionMap.lookup prod inverse + ProductionMap.lookup prod inverse with Not_found -> - TerminalSet.empty + TerminalSet.empty in ProductionMap.add prod (TerminalSet.add tok toks) inverse ) reductions ProductionMap.empty - + (* ------------------------------------------------------------------------ *) (* [has_beforeend s] tests whether the state [s] can reduce a production whose semantic action uses [$endpos($0)]. Note that [$startpos] and @@ -880,9 +880,9 @@ SymbolMap.fold (fun symbol _ covered -> match symbol with | Symbol.T tok -> - TerminalSet.add tok covered + TerminalSet.add tok covered | Symbol.N _ -> - covered + covered ) transitions TerminalSet.empty in @@ -930,18 +930,18 @@ | prod :: prods -> match Precedence.reduce_reduce choice prod with | Some choice -> - best choice prods + best choice prods | None -> (* The cause for not knowing which production is best could be: 1- the productions originate in different source files; - 2- they are derived, via inlining, from the same production. *) - Error.signal - (Production.positions choice @ Production.positions prod) - "do not know how to resolve a reduce/reduce conflict\n\ + 2- they are derived, via inlining, from the same production. *) + Error.signal + (Production.positions choice @ Production.positions prod) + "do not know how to resolve a reduce/reduce conflict\n\ between the following two productions:\n%s\n%s" (Production.print choice) (Production.print prod); - choice (* dummy *) + choice (* dummy *) (* Go ahead. *) @@ -957,31 +957,31 @@ 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; + 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 + 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 @@ -1004,58 +1004,58 @@ 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. + 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). *) + 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 + 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 + 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\ + 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)) + | 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 end with Not_found -> @@ -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]. *) @@ -1159,9 +1169,9 @@ let nt : Nonterminal.t = match Production.classify prod with | Some nt -> - nt + nt | None -> - assert false (* this is a start production *) + assert false (* this is a start production *) in let t : Stretch.ocamltype = Nonterminal.ocamltype_of_start_symbol nt diff -Nru menhir-20151112.dfsg/src/lr1partial.ml menhir-20160808+dfsg/src/lr1partial.ml --- menhir-20151112.dfsg/src/lr1partial.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/lr1partial.ml 2016-08-08 19:19:04.000000000 +0000 @@ -93,59 +93,59 @@ (* Otherwise, create a new node. *) let node = { - state = state; - ancestor = ancestor; - shadow = shadow; + state = state; + ancestor = ancestor; + shadow = shadow; } in map.(k) <- node :: similar; Queue.add node queue; (* Check whether this is a goal node. A node [N] is a goal node - if (i) [N] has a conflict involving one of the tokens of - interest and (ii) [N] corresponds to the goal node, that is, - the path that leads to [N] in the canonical LR(1) automaton - leads to the goal node in the merged LR(1) automaton. Note - that these conditions do not uniquely define [N]. *) + if (i) [N] has a conflict involving one of the tokens of + interest and (ii) [N] corresponds to the goal node, that is, + the path that leads to [N] in the canonical LR(1) automaton + leads to the goal node in the merged LR(1) automaton. Note + that these conditions do not uniquely define [N]. *) if shadow == X.goal then - let can_reduce = - ref TerminalSet.empty in - let reductions1 : Production.index list TerminalMap.t = - Lr1.reductions shadow in - List.iter (fun (toks, prod) -> - TerminalSet.iter (fun tok -> - - (* We are looking at a [(tok, prod)] pair -- a reduction - in the canonical automaton state. *) - - (* Check that this reduction, which exists in the canonical - automaton state, also exists in the merged automaton -- - that is, it wasn't suppressed by conflict resolution. *) - - if List.mem prod (TerminalMap.lookup tok reductions1) then - - try - let (_ : Lr1.node) = - SymbolMap.find (Symbol.T tok) (Lr1.transitions shadow) - in - (* Shift/reduce conflict. *) - raise (Goal (node, tok)) - with Not_found -> - let toks = !can_reduce in - (* We rely on the property that [TerminalSet.add tok toks] - preserves physical equality when [tok] is a member of - [toks]. *) - let toks' = TerminalSet.add tok toks in - if toks == toks' then - (* Reduce/reduce conflict. *) - raise (Goal (node, tok)) - else - (* No conflict so far. *) - can_reduce := toks' + let can_reduce = + ref TerminalSet.empty in + let reductions1 : Production.index list TerminalMap.t = + Lr1.reductions shadow in + List.iter (fun (toks, prod) -> + TerminalSet.iter (fun tok -> + + (* We are looking at a [(tok, prod)] pair -- a reduction + in the canonical automaton state. *) + + (* Check that this reduction, which exists in the canonical + automaton state, also exists in the merged automaton -- + that is, it wasn't suppressed by conflict resolution. *) + + if List.mem prod (TerminalMap.lookup tok reductions1) then + + try + let (_ : Lr1.node) = + SymbolMap.find (Symbol.T tok) (Lr1.transitions shadow) + in + (* Shift/reduce conflict. *) + raise (Goal (node, tok)) + with Not_found -> + let toks = !can_reduce in + (* We rely on the property that [TerminalSet.add tok toks] + preserves physical equality when [tok] is a member of + [toks]. *) + let toks' = TerminalSet.add tok toks in + if toks == toks' then + (* Reduce/reduce conflict. *) + raise (Goal (node, tok)) + else + (* No conflict so far. *) + can_reduce := toks' - ) toks - ) (Lr0.reductions state) + ) toks + ) (Lr0.reductions state) end @@ -157,40 +157,40 @@ try ProductionMap.iter (fun (prod : Production.index) (k : Lr0.node) -> - let shadow = try - ProductionMap.find prod Lr1.entry - with Not_found -> - assert false - in - if relevant shadow then - explore None shadow (restrict (Lr0.start k)) + let shadow = try + ProductionMap.find prod Lr1.entry + with Not_found -> + assert false + in + if relevant shadow then + explore None shadow (restrict (Lr0.start k)) ) Lr0.entry; Misc.qiter (fun node -> - SymbolMap.iter (fun symbol state -> - try - let shadow = - SymbolMap.find symbol (Lr1.transitions node.shadow) in - if relevant shadow then - explore (Some (symbol, node)) shadow (restrict state) - with Not_found -> - (* No shadow. This can happen if a shift/reduce conflict + SymbolMap.iter (fun symbol state -> + try + let shadow = + SymbolMap.find symbol (Lr1.transitions node.shadow) in + if relevant shadow then + explore (Some (symbol, node)) shadow (restrict state) + with Not_found -> + (* No shadow. This can happen if a shift/reduce conflict was resolved in favor in reduce. Ignore that transition. *) () - ) (Lr0.transitions node.state) + ) (Lr0.transitions node.state) ) queue; (* We didn't find a goal node. This shouldn't happen! If the - goal node in the merged LR(1) automaton has a conflict, - then there should exist a node with a conflict in the - canonical automaton as well. Otherwise, Pager's construction - is incorrect. *) - + goal node in the merged LR(1) automaton has a conflict, + then there should exist a node with a conflict in the + canonical automaton as well. Otherwise, Pager's construction + is incorrect. *) + raise Oops with Goal (node, tok) -> node, tok - + (* Query the goal node that was found about the shortest path from it to one of the entry nodes. *) @@ -199,9 +199,9 @@ let rec follow path node = match node.ancestor with | None -> - Lr1.start2item node.shadow, Array.of_list path + Lr1.start2item node.shadow, Array.of_list path | Some (symbol, node) -> - follow (symbol :: path) node + follow (symbol :: path) node in follow [] goal diff -Nru menhir-20151112.dfsg/src/LRijkstra.ml menhir-20160808+dfsg/src/LRijkstra.ml --- menhir-20151112.dfsg/src/LRijkstra.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/LRijkstra.ml 2016-08-08 19:19:04.000000000 +0000 @@ -209,9 +209,9 @@ match Lr1.incoming_symbol s with | None | Some (Symbol.T _) -> - true + true | Some (Symbol.N _) -> - false + false (* [reduction_path_exists s w prod] tests whether the path determined by the sequence of symbols [w] out of the state [s] exists in the automaton and @@ -484,7 +484,7 @@ (* To save memory (and therefore time), we encode a fact in a single OCaml integer value. This is made possible by the fact that tries, words, and - terminal symbols are represented as (or can be encoded as) integers. + terminal symbols are represented as (or can be encoded as) integers. This admittedly horrible hack allows us to save roughly a factor of 2 in space, and to gain 10% in time. *) @@ -682,7 +682,7 @@ (whose word has minimal length). Indeed, we are not interested in keeping track of several words that produce the same effect. Only the shortest such word is of interest. - + Thus, the total number of facts accumulated by the algorithm is at most [T.n^2], where [T] is the total size of the tries that we have constructed, and [n] is the number of terminal symbols. (This number can be quite large. @@ -797,7 +797,7 @@ (* The module [E] is in charge of recording the non-terminal edges that we have discovered, or more precisely, the conditions under which these edges can be taken. - + It maintains a set of quadruples [s, nt, w, z], where such a quadruple means that in the state [s], the outgoing edge labeled [nt] can be taken by consuming the word [w], under the assumption that the next symbol is [z]. @@ -817,13 +817,16 @@ quadruple [s, nt, a, z] is new. The symbol [z] cannot be [any]. *) val register: Lr1.node -> Nonterminal.t -> W.word -> Terminal.t -> bool - (* [query s nt a z] enumerates all words [w] such that, in state [s], the - outgoing edge labeled [nt] can be taken by consuming the word [w], under - the assumption that the next symbol is [z], and the first symbol of the - word [w.z] is [a]. The symbol [a] can be [any]. The symbol [z] cannot be - [any]. *) - val query: Lr1.node -> Nonterminal.t -> Terminal.t -> Terminal.t -> - (W.word -> unit) -> unit + (* [query s nt a foreach] enumerates all words [w] and all real symbols [z] + such that, in state [s], the outgoing edge labeled [nt] can be taken by + consuming the word [w], under the assumption that the next symbol is [z], + and the first symbol of the word [w.z] is [a]. The symbol [a] can be [any]. + The function [foreach] can be either [foreach_terminal] or of the form + [foreach_terminal_not_causing_an_error _]. It limits the symbols [z] that + are considered. *) + val query: Lr1.node -> Nonterminal.t -> Terminal.t -> + (* foreach: *) ((Terminal.t -> unit) -> unit) -> + (W.word -> Terminal.t -> unit) -> unit (* [size()] returns the number of edges currently stored in the set. *) val size: unit -> int @@ -879,25 +882,26 @@ true end - let rec query s nt a z f = - assert (Terminal.real z); + let rec query s nt a foreach f = if Terminal.equal a any then begin (* If [a] is [any], we query the table for every real symbol [a]. We can limit ourselves to symbols that do not cause an error in state [s]. Those that do certainly do not have an entry; see the assertion in [register] above. *) foreach_terminal_not_causing_an_error s (fun a -> - query s nt a z f + query s nt a foreach f ) end - else begin + else let i = index s in let m = table.(i) in - let key = pack nt a z in - match H.find m key with - | w -> f w - | exception Not_found -> () - end + foreach (fun z -> + assert (Terminal.real z); + let key = pack nt a z in + match H.find m key with + | w -> f w z + | exception Not_found -> () + ) let size () = !count @@ -968,7 +972,7 @@ (* Throughout this rather long function, there is just one [fact]. Let's name its components right now, so as to avoid accessing them several times. (That could be costly, as it requires decoding the fact.) *) - let position = position fact + let position = position fact and lookahead = lookahead fact and word = word fact in let source = Trie.source position @@ -977,7 +981,7 @@ (* 1. View [fact] as a vertex. Examine the transitions out of [current]. For every transition labeled by a symbol [sym] and into a state [target], ... *) - + Lr1.transitions current |> SymbolMap.iter (fun sym target -> (* ... try to follow this transition in the trie [position], down to a child which we call [child]. *) @@ -990,7 +994,7 @@ () | child, Symbol.T t -> - + (* 1a. The transition exists in the trie, and [sym] is in fact a terminal symbol [t]. We note that [t] cannot be the [error] token, because the trie does not have any edges labeled [error]. *) @@ -1001,7 +1005,7 @@ (* If the lookahead assumption [lookahead] is compatible with [t], then we derive a new fact, where one more edge has been taken, and enqueue this new fact for later examination. *) - + (* The state [target] is solid, i.e., its incoming symbol is terminal. This state is always entered without consideration for the next lookahead symbol. Thus, we can use [any] as the lookahead assumption @@ -1016,8 +1020,8 @@ (* 1b. The transition exists in the trie, and [sym] is in fact a nonterminal symbol [nt]. *) - assert (Lr1.Node.compare (Trie.current child) target = 0); - assert (not (is_solid target)); + assert (Lr1.Node.compare (Trie.current child) target = 0); + assert (not (is_solid target)); (* We need to know how this nonterminal edge can be taken. We query [E] for a word [w] that allows us to take this edge. In general, @@ -1029,20 +1033,14 @@ (* It could be the case that, due to a default reduction, the answer to our query does not depend on [z], and we are wasting work. - However, allowing [z] to be [any] in [E.query], and taking + However, allowing [z] to be [any] in [E.query], and taking advantage of this to increase performance, seems difficult. *) - (* Remark by Jacques-Henri Jourdan: we could remove the outer loop - on [z], remove the parameter [z] to [E.query], and let [E.query] - itself enumerate all values of [z]. Potentially this could allow - a more efficient implementation of the data structure [E]. *) - - foreach_terminal_not_causing_an_error target (fun z -> - E.query current nt lookahead z (fun w -> - assert (compatible lookahead (W.first w z)); - let word = W.append word w in - enqueue child word z - ) + let foreach = foreach_terminal_not_causing_an_error target in + E.query current nt lookahead foreach (fun w z -> + assert (compatible lookahead (W.first w z)); + let word = W.append word w in + enqueue child word z ) ); @@ -1225,11 +1223,9 @@ of the word [w.z'] is [z]. For every [z'] and [w] that fulfill these requirements, we have an edge to [s', z'], labeled with the word [w]. *) - foreach_terminal (fun z' -> - E.query s nt z z' (fun w -> - edge w (W.length w) (s', z') - ) - ) + E.query s nt z foreach_terminal (fun w z' -> + edge w (W.length w) (s', z') + ) ) (* Algorithm A*, used with a zero estimate, is Dijkstra's algorithm. diff -Nru menhir-20151112.dfsg/src/Makefile menhir-20160808+dfsg/src/Makefile --- menhir-20151112.dfsg/src/Makefile 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Makefile 2016-08-08 19:19:04.000000000 +0000 @@ -43,9 +43,8 @@ # Checking the version of the OCaml compiler. .versioncheck: - @ echo Checking that Objective Caml is recent enough... - @$(OCAMLBUILD) -build-dir _stage1 checkOCamlVersion.byte - @ _stage1/checkOCamlVersion.byte --verbose --gt "4.02" + @ echo Checking that OCaml is recent enough... + @ ocaml checkOCamlVersion.ml --verbose --gt "4.02" @ touch $@ # ---------------------------------------------------------------------------- diff -Nru menhir-20151112.dfsg/src/Maps.ml menhir-20160808+dfsg/src/Maps.ml --- menhir-20151112.dfsg/src/Maps.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Maps.ml 2016-08-08 19:19:04.000000000 +0000 @@ -33,21 +33,21 @@ module PersistentMapsToImperativeMaps (M : PERSISTENT_MAPS) : IMPERATIVE_MAPS with type key = M.key - and type 'data t = 'data M.t ref + 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 @@ -63,7 +63,7 @@ (M : IMPERATIVE_MAPS) (D : sig type data end) : IMPERATIVE_MAP with type key = M.key - and type data = D.data + and type data = D.data = struct type key = @@ -113,17 +113,17 @@ let find key m = match m.(key) with | None -> - raise Not_found + raise Not_found | Some data -> - data + data let iter f m = Array.iteri (fun key data -> match data with | None -> - () + () | Some data -> - f key data + f key data ) m end diff -Nru menhir-20151112.dfsg/src/Maps.mli menhir-20160808+dfsg/src/Maps.mli --- menhir-20151112.dfsg/src/Maps.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/Maps.mli 2016-08-08 19:19:04.000000000 +0000 @@ -44,7 +44,7 @@ module PersistentMapsToImperativeMaps (M : PERSISTENT_MAPS) : IMPERATIVE_MAPS with type key = M.key - and type 'data t = 'data M.t ref + 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]. *) @@ -53,7 +53,7 @@ (M : IMPERATIVE_MAPS) (D : sig type data end) : IMPERATIVE_MAP with type key = M.key - and type data = D.data + and type data = D.data (* An implementation of imperative maps as arrays is possible if keys are consecutive integers. *) diff -Nru menhir-20151112.dfsg/src/menhirLib.mlpack menhir-20160808+dfsg/src/menhirLib.mlpack --- menhir-20151112.dfsg/src/menhirLib.mlpack 2015-11-12 20:02:03.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-20151112.dfsg/src/META menhir-20160808+dfsg/src/META --- menhir-20151112.dfsg/src/META 2015-11-12 20:02:04.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 = "20151112" +version = "20160808" diff -Nru menhir-20151112.dfsg/src/misc.ml menhir-20160808+dfsg/src/misc.ml --- menhir-20151112.dfsg/src/misc.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/misc.ml 2016-08-08 19:19:04.000000000 +0000 @@ -53,23 +53,23 @@ let image = f element in begin match image with | Some _ -> - incr c + incr c | None -> - () + () end; image ) in get, !c -module IntSet = Set.Make (struct - type t = int - let compare = ( - ) - end) +module IntSet = Set.Make (struct + type t = int + let compare = ( - ) + end) type 'a iter = ('a -> unit) -> unit -let separated_iter_to_string printer separator iter = +let separated_iter_to_string printer separator iter = let b = Buffer.create 32 in let first = ref true in iter (fun x -> @@ -84,7 +84,7 @@ ); Buffer.contents b -let separated_list_to_string printer separator xs = +let separated_list_to_string printer separator xs = separated_iter_to_string printer separator (fun f -> List.iter f xs) let terminated_iter_to_string printer terminator iter = @@ -98,19 +98,19 @@ let terminated_list_to_string printer terminator xs = terminated_iter_to_string printer terminator (fun f -> List.iter f xs) -let index_map string_map = +let index_map string_map = let n = StringMap.cardinal string_map in let a = Array.make n None in - let conv, _ = StringMap.fold + let conv, _ = StringMap.fold (fun k v (conv, idx) -> a.(idx) <- Some (k, v); StringMap.add k idx conv, idx + 1) - string_map (StringMap.empty, 0) + string_map (StringMap.empty, 0) in ((fun n -> snd (unSome a.(n))), (fun k -> StringMap.find k conv), (fun n -> fst (unSome a.(n)))) - + let support_assoc l x = try List.assoc x l @@ -131,9 +131,9 @@ let rec loop x = match Hashtbl.find table x with | None -> - [] + [] | Some x -> - x :: loop x + x :: loop x in loop x @@ -212,9 +212,9 @@ let x' = f x and xs' = smap f xs in if x == x' && xs == xs' then - l + l else - x' :: xs' + x' :: xs' let rec smapa f accu = function | [] -> @@ -224,9 +224,9 @@ let accu, xs' = smapa f accu xs in accu, if x == x' && xs == xs' then - l + l else - x' :: xs' + x' :: xs' let normalize s = let s = Bytes.of_string s in @@ -236,9 +236,9 @@ | '(' | ')' | ',' -> - Bytes.set s i '_' + Bytes.set s i '_' | _ -> - () + () done; Bytes.unsafe_to_string s @@ -250,7 +250,7 @@ x (* [map_opt f l] returns the list of [y]s such that [f x = Some y] where [x] - is in [l], preserving the order of elements of [l]. *) + is in [l], preserving the order of elements of [l]. *) let map_opt f l = List.(rev (fold_left (fun ys x -> match f x with @@ -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-20151112.dfsg/src/misc.mli menhir-20160808+dfsg/src/misc.mli --- menhir-20151112.dfsg/src/misc.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/misc.mli 2016-08-08 19:19:04.000000000 +0000 @@ -64,7 +64,7 @@ module IntSet : Set.S with type elt = int (* [separated_list_to_string printer sep l] converts [l] into a string - representation built by using [printer] on each element and [sep] as + representation built by using [printer] on each element and [sep] as a separator. *) type 'a iter = ('a -> unit) -> unit @@ -73,22 +73,22 @@ val separated_list_to_string: ('a -> string) -> string -> 'a list -> string (* [terminated_list_to_string printer term l] converts [l] into a string - representation built by using [printer] on each element and [term] as + representation built by using [printer] on each element and [term] as a terminator. *) val terminated_list_to_string: ('a -> string) -> string -> 'a list -> string val terminated_iter_to_string: ('a -> string) -> string -> 'a iter -> string (* [index_map f] returns a triple (indexed_f, domain_indexation, domain_array). - [indexed_f] is a mapping from [0..n-1] to the elements of the map [f] - ([n] being the size of the image of [f]). - [domain_indexation] is a mapping from the domain of the map [f] to indexes. - [domain_array] is a mapping from the indexes to the domain of [f]. + [indexed_f] is a mapping from [0..n-1] to the elements of the map [f] + ([n] being the size of the image of [f]). + [domain_indexation] is a mapping from the domain of the map [f] to indexes. + [domain_array] is a mapping from the indexes to the domain of [f]. The indexation implements [f] ie: - forall x in domain(m), indexed_f (domain_indexation x) = f (x). - forall x in domain(m), domain_array (domain_indexation x) = x. *) -val index_map +val index_map : 'a StringMap.t -> (int -> 'a) * (string -> int) * (int -> string) (* [support_assoc l x] returns the second component of the first couple @@ -160,7 +160,7 @@ val postincrement: int ref -> int (* [map_opt f l] returns the list of [y]s such that [f x = Some y] where [x] - is in [l], preserving the order of elements of [l]. *) + is in [l], preserving the order of elements of [l]. *) val map_opt : ('a -> 'b option) -> 'a list -> 'b list (* [new_intern capacity] creates a new service for interning (hash-consing) @@ -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-20151112.dfsg/src/myocamlbuild.ml menhir-20160808+dfsg/src/myocamlbuild.ml --- menhir-20151112.dfsg/src/myocamlbuild.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/myocamlbuild.ml 2016-08-08 19:19:04.000000000 +0000 @@ -2,6 +2,59 @@ open Command (* ---------------------------------------------------------------------------- *) + +(* This compatibility layer allows us to support both OCaml 4.02 and 4.03, with + deprecation errors activated. We define our own copies of certain 4.03 + functions. *) + +module Compatibility = struct + + module Char = struct + + let lowercase_ascii c = + if (c >= 'A' && c <= 'Z') + then Char.chr (Char.code c + 32) + else c + + let uppercase_ascii c = + if (c >= 'a' && c <= 'z') + then Char.chr (Char.code c - 32) + else c + + end + + module Bytes = struct + + include Bytes + + let apply1 f s = + if Bytes.length s = 0 then s else begin + let r = Bytes.copy s in + Bytes.unsafe_set r 0 (f (Bytes.unsafe_get s 0)); + r + end + + let capitalize_ascii s = + apply1 Char.uppercase_ascii s + + let uncapitalize_ascii s = + apply1 Char.lowercase_ascii s + + end + + module String = struct + + let capitalize_ascii s = + Bytes.unsafe_to_string (Bytes.capitalize_ascii (Bytes.unsafe_of_string s)) + + let uncapitalize_ascii s = + Bytes.unsafe_to_string (Bytes.uncapitalize_ascii (Bytes.unsafe_of_string s)) + + end + +end + +(* ---------------------------------------------------------------------------- *) (* The following rules can be copied into other projects. *) (* ---------------------------------------------------------------------------- *) @@ -42,7 +95,7 @@ let cmx (m : string) : string = let candidate = m ^ ".cmx" in - if Sys.file_exists (m ^ ".ml") then candidate else String.uncapitalize candidate + if Sys.file_exists (m ^ ".ml") then candidate else Compatibility.String.uncapitalize_ascii candidate (* ---------------------------------------------------------------------------- *) @@ -56,7 +109,7 @@ let for_pack (basename : string) = let filename = basename ^ ".mlpack" in let modules = List.filter noncomment (lines filename) in - let library = String.capitalize basename in + let library = Compatibility.String.capitalize_ascii basename in let tags = [ Printf.sprintf "for-pack(%s)" library ] in List.iter (fun m -> tag_file (cmx m) tags @@ -193,7 +246,7 @@ "parser.mly" ; (* Create [Driver.ml] by copying the appropriate source file. *) - copy_rule "create Driver.ml" + copy_rule "create Driver.ml" (* source: *) (if fancy() then "fancyDriver.ml" else "yaccDriver.ml") (* target: *) @@ -216,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-20151112.dfsg/src/nonTerminalDefinitionInlining.ml menhir-20160808+dfsg/src/nonTerminalDefinitionInlining.ml --- menhir-20151112.dfsg/src/nonTerminalDefinitionInlining.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/nonTerminalDefinitionInlining.ml 2016-08-08 19:19:04.000000000 +0000 @@ -6,7 +6,7 @@ exception NoInlining (* Color are used to detect cycles. *) -type 'a color = +type 'a color = | BeingExpanded | Expanded of 'a @@ -58,35 +58,35 @@ (* Inline a grammar. The resulting grammar does not contain any definitions that can be inlined. *) -let inline grammar = +let inline grammar = - let names producers = - List.fold_left (fun s (_, x) -> StringSet.add x s) - StringSet.empty producers + let names producers = + List.fold_left (fun s (_, x) -> StringSet.add x s) + StringSet.empty producers in - (* This function returns a fresh name beginning with [prefix] and + (* This function returns a fresh name beginning with [prefix] and that is not in the set of names [names]. *) let rec fresh ?(c=0) names prefix = let name = prefix^string_of_int c in if StringSet.mem name names then - fresh ~c:(c+1) names prefix - else - name + fresh ~c:(c+1) names prefix + else + name in let use_inline = ref false in (* This table associates a color to each non terminal that can be expanded. *) - let expanded_non_terminals = - Hashtbl.create 13 + let expanded_non_terminals = + Hashtbl.create 13 in - let expanded_state k = - Hashtbl.find expanded_non_terminals k + let expanded_state k = + Hashtbl.find expanded_non_terminals k in - - let mark_as_being_expanded k = + + let mark_as_being_expanded k = Hashtbl.add expanded_non_terminals k BeingExpanded in @@ -98,33 +98,33 @@ (* This function traverses the producers of the branch [b] and find the first non terminal that can be inlined. If it finds one, it inlines its branches into [b], that's why this function can return - several branches. If it does not find one non terminal to be + several branches. If it does not find one non terminal to be inlined, it raises [NoInlining]. *) - let rec find_inline_producer b = - let prefix, nt, p, psym, suffix = + let rec find_inline_producer b = + let prefix, nt, p, psym, suffix = let rec chop_inline i (prefix, suffix) = - match suffix with - | [] -> - raise NoInlining - - | ((nt, id) as x) :: xs -> - try - let r = StringMap.find nt grammar.rules in - if r.inline_flag then - (* We have to inline the rule [r] into [b] between - [prefix] and [xs]. *) - List.rev prefix, nt, r, id, xs - else - chop_inline (i + 1) (x :: prefix, xs) - with Not_found -> - chop_inline (i + 1) (x :: prefix, xs) + match suffix with + | [] -> + raise NoInlining + + | ((nt, id) as x) :: xs -> + try + let r = StringMap.find nt grammar.rules in + if r.inline_flag then + (* We have to inline the rule [r] into [b] between + [prefix] and [xs]. *) + List.rev prefix, nt, r, id, xs + else + chop_inline (i + 1) (x :: prefix, xs) + with Not_found -> + chop_inline (i + 1) (x :: prefix, xs) in - chop_inline 1 ([], b.producers) + chop_inline 1 ([], b.producers) in prefix, expand_rule nt p, nt, psym, suffix - (* We have to rename producers' names of the inlined production - if they clash with the producers' names of the branch into + (* We have to rename producers' names of the inlined production + if they clash with the producers' names of the branch into which we do the inlining. *) and rename_if_necessary b producers = @@ -133,29 +133,55 @@ (* Compute a renaming and the new inlined producers' names. *) let phi, producers' = - List.fold_left (fun (phi, producers) (p, x) -> - if StringSet.mem x producers_names then - let x' = fresh producers_names x in - ((x, x') :: phi, (p, x') :: producers) - else - (phi, (p, x) :: producers) + List.fold_left (fun (phi, producers) (p, x) -> + if StringSet.mem x producers_names then + let x' = fresh producers_names x in + ((x, x') :: phi, (p, x') :: producers) + else + (phi, (p, x) :: producers) ) ([], []) producers in phi, List.rev producers' - - (* Inline the non terminals that can be inlined in [b]. We use the + + (* Inline the non terminals that can be inlined in [b]. We use the ListMonad to combine the results. *) and expand_branch (b : branch) : branch ListMonad.m = try (* [c] is the identifier under which the callee is known. *) - let prefix, p, _nt, c, suffix = find_inline_producer b in + let prefix, p, nt, c, suffix = find_inline_producer b in use_inline := true; (* Inline a branch of [nt] at position [prefix] ... [suffix] in - the branch [b]. *) + the branch [b]. *) let inline_branch pb = - (* Rename the producers of this branch is they conflict with - the name of the host's producers. *) - let phi, inlined_producers = rename_if_necessary b pb.producers in + + (* 2015/11/18. The interaction of %prec and %inline is not documented. + It used to be the case that we would disallow marking a production + both %inline and %prec. Now, we allow it, but we check that (1) it + is inlined at the last position of the host production and (2) the + host production does not already have a %prec annotation. *) + pb.branch_prec_annotation |> Option.iter (fun callee_prec -> + (* The callee has a %prec annotation. *) + (* Check condition 1. *) + if List.length suffix > 0 then + Error.error [ Positions.position callee_prec; b.branch_position ] + "this production carries a %%prec annotation,\n\ + and the nonterminal symbol %s is marked %%inline.\n\ + For this reason, %s can be used only in tail position." + nt nt; + (* Check condition 2. *) + b.branch_prec_annotation |> Option.iter (fun caller_prec -> + Error.error [ Positions.position callee_prec; Positions.position caller_prec ] + "this production carries a %%prec annotation,\n\ + and the nonterminal symbol %s is marked %%inline.\n\ + For this reason, %s cannot be used in a production\n\ + which itself carries a %%prec annotation." + nt nt + ) + ); + + (* Rename the producers of this branch is they conflict with + the name of the host's producers. *) + let phi, inlined_producers = rename_if_necessary b pb.producers in (* After inlining, the producers are as follows. *) let producers = prefix @ inlined_producers @ suffix in @@ -198,9 +224,9 @@ production is the start production of the outer production. This is true only if the inner production is non-epsilon. *) - in + in - let endp = + let endp = if inlined_producers > 0 then (* If the inner production is non-epsilon, things are easy, then its end position is the end position of its last element. *) @@ -225,17 +251,31 @@ Before, WhereEnd in - (* Rename the outer and inner semantic action. *) - let outer_action = - Action.rename (rename_sw_outer (c, startp, endp)) [] b.action - and action' = - Action.rename (rename_sw_inner beforeendp) phi pb.action - in - - { b with - producers = producers; - action = Action.compose c action' outer_action - } + (* Rename the outer and inner semantic action. *) + let outer_action = + Action.rename (rename_sw_outer (c, startp, endp)) [] b.action + and action' = + Action.rename (rename_sw_inner beforeendp) phi pb.action + in + + (* 2015/11/18. If the callee has a %prec annotation (which implies + the caller does not have one, and the callee appears in tail + position in the caller) then the annotation is inherited. This + seems reasonable, but remains undocumented. *) + let branch_prec_annotation = + match pb.branch_prec_annotation with + | (Some _) as annotation -> + assert (b.branch_prec_annotation = None); + annotation + | None -> + b.branch_prec_annotation + in + + { b with + producers; + action = Action.compose c action' outer_action; + branch_prec_annotation; + } in List.map inline_branch p.branches >>= expand_branch @@ -243,15 +283,15 @@ return b (* Expand a rule if necessary. *) - and expand_rule k r = - try + and expand_rule k r = + try (match expanded_state k with - | BeingExpanded -> - Error.error - r.positions - "there is a cycle in the definition of %s." k - | Expanded r -> - r) + | BeingExpanded -> + Error.error + r.positions + "there is a cycle in the definition of %s." k + | Expanded r -> + r) with Not_found -> mark_as_being_expanded k; mark_as_expanded k { r with branches = r.branches >>= expand_branch } @@ -260,27 +300,40 @@ (* If we are in Coq mode, %inline is forbidden. *) let _ = if Settings.coq then - StringMap.iter - (fun _ r -> - if r.inline_flag then + StringMap.iter + (fun _ r -> + if r.inline_flag then Error.error r.positions "%%inline is not supported by the Coq back-end.") grammar.rules in - (* To expand a grammar, we expand all its rules and remove - the %inline rules. *) - let expanded_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-20151112.dfsg/src/PackedIntArray.ml menhir-20160808+dfsg/src/PackedIntArray.ml --- menhir-20151112.dfsg/src/PackedIntArray.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/PackedIntArray.ml 2016-08-08 19:19:04.000000000 +0000 @@ -36,12 +36,12 @@ else let rec check k max = (* [max] equals [2^k] *) if (max <= 0) || (v < max) then - k - (* if [max] just overflew, then [v] requires a full ocaml - integer, and [k] is the number of bits in an ocaml integer - plus one, that is, [Sys.word_size]. *) + k + (* if [max] just overflew, then [v] requires a full ocaml + integer, and [k] is the number of bits in an ocaml integer + plus one, that is, [Sys.word_size]. *) else - check (2 * k) (max * max) + check (2 * k) (max * max) in check 1 2 @@ -55,7 +55,7 @@ let pack (a : int array) : t = let m = Array.length a in - + (* Compute the maximum magnitude of the array elements. This tells us how many bits per element we are going to use. *) @@ -82,9 +82,9 @@ let n = if m mod w = 0 then - m / w + m / w else - m / w + 1 + m / w + 1 in let s = @@ -98,11 +98,11 @@ let next () = let ii = !i in if ii = m then - 0 (* ran off the end, pad with zeroes *) + 0 (* ran off the end, pad with zeroes *) else - let v = a.(ii) in - i := ii + 1; - v + let v = a.(ii) in + i := ii + 1; + v in (* Fill up the string. *) @@ -110,7 +110,7 @@ for j = 0 to n - 1 do let c = ref 0 in for _x = 1 to w do - c := (!c lsl k) lor next() + c := (!c lsl k) lor next() done; Bytes.set s j (Char.chr !c) done; @@ -142,8 +142,8 @@ for i = 0 to m - 1 do let v = ref a.(i) in for x = 1 to w do - Bytes.set s ((i + 1) * w - x) (Char.chr (!v land 255)); - v := !v lsr 8 + Bytes.set s ((i + 1) * w - x) (Char.chr (!v land 255)); + v := !v lsr 8 done done; diff -Nru menhir-20151112.dfsg/src/parameterizedGrammar.ml menhir-20160808+dfsg/src/parameterizedGrammar.ml --- menhir-20151112.dfsg/src/parameterizedGrammar.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/parameterizedGrammar.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,14 +1,13 @@ open Positions open Syntax open UnparameterizedSyntax -open InternalSyntax open Misc (* Inference for non terminals. *) (* Unification variables convey [variable_info] to describe the multi-equation they take part of. *) -type variable_info = +type variable_info = { mutable structure : nt_type option; mutable name : string option; @@ -19,11 +18,11 @@ between multi-equations. *) and variable = variable_info UnionFind.point -(* Types are simple types. +(* Types are simple types. [star] denotes the type of ground symbol (non terminal or terminal). [Arrow] describes the type of a parameterized non terminal. *) -and nt_type = - Arrow of variable list +and nt_type = + Arrow of variable list let star = Arrow [] @@ -31,83 +30,83 @@ (* [var_name] is a name generator for unification variables. *) let var_name = let name_counter = ref (-1) in - let next_name () = + let next_name () = incr name_counter; String.make 1 (char_of_int (97 + !name_counter mod 26)) ^ let d = !name_counter / 26 in if d = 0 then "" else string_of_int d in - fun v -> - let repr = UnionFind.find v in - match repr.name with - None -> let name = next_name () in repr.name <- Some name; name - | Some x -> x + fun v -> + let repr = UnionFind.find v in + match repr.name with + None -> let name = next_name () in repr.name <- Some name; name + | Some x -> x -(* [string_of_nt_type] is a simple pretty printer for types (they can be +(* [string_of_nt_type] is a simple pretty printer for types (they can be recursive). *) (* 2011/04/05: types can no longer be recursive, but I won't touch the printer -fpottier *) -let string_of paren_fun ?paren ?colors t : string = - let colors = - match colors with - None -> (Mark.fresh (), Mark.fresh ()) - | Some cs -> cs +let string_of paren_fun ?paren ?colors t : string = + let colors = + match colors with + None -> (Mark.fresh (), Mark.fresh ()) + | Some cs -> cs in let s, p = paren_fun colors t in - if paren <> None && p = true then + if paren <> None && p = true then "("^ s ^")" else s let rec paren_nt_type colors = function (* [colors] is a pair [white, black] *) - - Arrow [] -> + + Arrow [] -> "*", false | Arrow ins -> - let args = separated_list_to_string - (string_of paren_var ~paren:true ~colors) ", " ins + let args = separated_list_to_string + (string_of paren_var ~paren:true ~colors) ", " ins in - let args = - if List.length ins > 1 then - "("^ args ^ ")" - else - args + let args = + if List.length ins > 1 then + "("^ args ^ ")" + else + args in - args^" -> *", true - -and paren_var (white, black) x = + args^" -> *", true + +and paren_var (white, black) x = let descr = UnionFind.find x in if Mark.same descr.mark white then begin descr.mark <- black; var_name x, false - end - else begin + end + else begin descr.mark <- white; let s, p = match descr.structure with - None -> var_name x, false - | Some t -> paren_nt_type (white, black) t + None -> var_name x, false + | Some t -> paren_nt_type (white, black) t in - if Mark.same descr.mark black then - (var_name x ^ " = " ^ s, true) - else - (s, p) + if Mark.same descr.mark black then + (var_name x ^ " = " ^ s, true) + else + (s, p) end -let string_of_nt_type ?colors t = +let string_of_nt_type ?colors t = (* TEMPORARY note: always called without a [colors] argument! *) string_of ?colors paren_nt_type t -let string_of_var ?colors v = +let string_of_var ?colors v = (* TEMPORARY note: always called without a [colors] argument! *) string_of ?colors paren_var v (* for debugging: (* [print_env env] returns a string description of the typing environment. *) -let print_env = - List.iter (fun (k, (_, v)) -> - Printf.eprintf "%s: %s\n" k (string_of_var v)) +let print_env = + List.iter (fun (k, (_, v)) -> + Printf.eprintf "%s: %s\n" k (string_of_var v)) *) @@ -118,15 +117,15 @@ let black = Mark.fresh () in let rec visit_var x = - let descr = UnionFind.find x in + let descr = UnionFind.find x in if not (Mark.same descr.mark black) then begin descr.mark <- black; action x; match descr.structure with | None -> - () - | Some t -> - visit_term t + () + | Some t -> + visit_term t end and visit_term (Arrow ins) = @@ -145,10 +144,10 @@ (* 2011/04/05: perform an eager occurs check and prevent the construction of any cycles. *) -let fresh_flexible_variable () = +let fresh_flexible_variable () = UnionFind.fresh { structure = None; name = None; mark = Mark.none } -let fresh_structured_variable t = +let fresh_structured_variable t = UnionFind.fresh { structure = Some t; name = None; mark = Mark.none } let star_variable = @@ -161,24 +160,24 @@ if not (UnionFind.equivalent x y) then let reprx, repry = UnionFind.find x, UnionFind.find y in match reprx.structure, repry.structure with - None, Some _ -> occurs_check x y; UnionFind.union x y - | Some _, None -> occurs_check y x; UnionFind.union y x - | None, None -> UnionFind.union x y - | Some t, Some t' -> unify toplevel t t'; UnionFind.union x y - -and unify toplevel t1 t2 = + None, Some _ -> occurs_check x y; UnionFind.union x y + | Some _, None -> occurs_check y x; UnionFind.union y x + | None, None -> UnionFind.union x y + | Some t, Some t' -> unify toplevel t t'; UnionFind.union x y + +and unify toplevel t1 t2 = match t1, t2 with | Arrow ins, Arrow ins' -> - let n1, n2 = List.length ins, List.length ins' in - if n1 <> n2 then - if n1 = 0 || n2 = 0 || not toplevel then - raise (UnificationError (t1, t2)) - else - (* the flag [toplevel] is used only here and influences which - exception is raised; BadArityError is raised only at toplevel *) - raise (BadArityError (n1, n2)); - List.iter2 (unify_var false) ins ins' + let n1, n2 = List.length ins, List.length ins' in + if n1 <> n2 then + if n1 = 0 || n2 = 0 || not toplevel then + raise (UnificationError (t1, t2)) + else + (* the flag [toplevel] is used only here and influences which + exception is raised; BadArityError is raised only at toplevel *) + raise (BadArityError (n1, n2)); + List.iter2 (unify_var false) ins ins' let unify_var x y = unify_var true x y @@ -188,49 +187,51 @@ (string * (Positions.t list * variable)) list (* [lookup x env] returns the type related to [x] in the typing environment - [env]. + [env]. By convention, identifiers that are not in [env] are terminals. They are - given the type [Star]. *) -let lookup x (env: environment) = - try + 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 unify_var inference_var checking_var - with - UnificationError (t1, t2) -> - Error.error - positions + with + UnificationError (t1, t2) -> + Error.error + positions "how is this symbol parameterized?\n\ - It is used at sorts %s and %s.\n\ + It is used at sorts %s and %s.\n\ The sort %s is not compatible with the sort %s." - (string_of_var inference_var) (string_of_var checking_var) - (string_of_nt_type t1) (string_of_nt_type t2) - + (string_of_var inference_var) (string_of_var checking_var) + (string_of_nt_type t1) (string_of_nt_type t2) + | BadArityError (n1, n2) -> - Error.error - positions - "does this symbol expect %d or %d arguments?" - (min n1 n2) (max n1 n2) + Error.error + positions + "does this symbol expect %d or %d arguments?" + (min n1 n2) (max n1 n2) | OccursError (x, y) -> - Error.error - positions + Error.error + positions "how is this symbol parameterized?\n\ - It is used at sorts %s and %s.\n\ + It is used at sorts %s and %s.\n\ The sort %s cannot be unified with the sort %s." - (string_of_var inference_var) (string_of_var checking_var) - (string_of_var x) (string_of_var y) - + (string_of_var inference_var) (string_of_var checking_var) + (string_of_var x) (string_of_var y) + (* An identifier can be used either in a total application or as a - higher-order non terminal (no partial application is allowed). *) + higher-order nonterminal (no partial application is allowed). *) let rec parameter_type env = function | ParameterVar x -> lookup x.value env @@ -238,79 +239,91 @@ | ParameterApp (x, args) -> assert (args <> []); let expected_type = - (* [x] is applied, it must be to the exact number - of arguments. *) - Arrow (List.map (parameter_type env) args) + (* [x] is applied, it must be to the exact number + of arguments. *) + Arrow (List.map (parameter_type env) args) in - (* Check the well-formedness of the application. *) - check [x.position] env x.value expected_type; + (* Check the well-formedness of the application. *) + check [x.position] env x.value expected_type; - (* Similarly, if it was a total application the result is - [Star] otherwise it is the flexible variable. *) - star_variable + (* Similarly, if it was a total application the result is + [Star] otherwise it is the flexible variable. *) + star_variable + + | ParameterAnonymous _ -> + (* 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 = +let check_grammar (p_grammar : Syntax.grammar) = (* [n] is the grammar size. *) let n = StringMap.cardinal p_grammar.p_rules in - (* The successors of the non terminal [N] are its producers. It + (* The successors of the non terminal [N] are its producers. It induce a graph over the non terminals and its successor function is implemented by [successors]. Non terminals are indexed using [nt]. - *) + *) let nt, conv, _iconv = index_map p_grammar.p_rules in - let parameters, name, branches, positions = + let parameters, name, branches, positions = (fun n -> (nt n).pr_parameters), (fun n -> (nt n).pr_nt), (fun n -> (nt n).pr_branches), (fun n -> (nt n).pr_positions) in - - (* The successors function is implemented as an array using the + + (* The successors function is implemented as an array using the indexing previously created. *) - let successors = - Array.init n (fun node -> + let successors = + Array.init n (fun node -> (* We only are interested by parameterized non terminals. *) if parameters node <> [] then - List.fold_left (fun succs { pr_producers = symbols } -> - List.fold_left (fun succs -> function (_, p) -> - let symbol, _ = Parameters.unapp p in - try - let symbol_node = conv symbol.value in - (* [symbol] is a parameterized non terminal, we add it - to the successors set. *) - if parameters symbol_node <> [] then - IntSet.add symbol_node succs - else - succs - with Not_found -> - (* [symbol] is a token, it is not interesting for type inference - purpose. *) - succs - ) succs symbols + List.fold_left (fun succs { pr_producers = symbols } -> + List.fold_left (fun succs -> function (_, p) -> + let symbol, _ = Parameters.unapp p in + try + let symbol_node = conv symbol.value in + (* [symbol] is a parameterized non terminal, we add it + to the successors set. *) + if parameters symbol_node <> [] then + IntSet.add symbol_node succs + else + succs + with Not_found -> + (* [symbol] is a token, it is not interesting for type inference + purpose. *) + succs + ) succs symbols ) IntSet.empty (branches node) else - Misc.IntSet.empty + Misc.IntSet.empty ) in - (* The successors function and the indexing induce the following graph + (* The successors function and the indexing induce the following graph module. *) - let module RulesGraph = + let module RulesGraph = struct - type node = int + type node = int - let n = n + let n = n - let index node = - node + let index node = + node - let successors f node = - IntSet.iter f successors.(node) + let successors f node = + IntSet.iter f successors.(node) - let iter f = - for i = 0 to n - 1 do - f i - done + let iter f = + for i = 0 to n - 1 do + f i + done end in @@ -321,152 +334,168 @@ - every parameterized non terminal definition always uses parameterized definitions of the same component with its formal parameters. - + Components are marked during the traversal: -1 means unvisited n with n > 0 is the number of parameters of the clique. *) let unseen = -1 in let marked_components = Array.make n unseen in - + let flexible_arrow args = let ty = Arrow (List.map (fun _ -> fresh_flexible_variable ()) args) in - fresh_structured_variable ty + fresh_structured_variable ty in (* [nt_type i] is the type of the i-th non terminal. *) let nt_type i = match parameters i with - | [] -> - star_variable - - | x -> - flexible_arrow x + | [] -> + star_variable + + | x -> + flexible_arrow x in - (* [actual_parameters_as_formal] is the well-formedness checker for + (* [actual_parameters_as_formal] is the well-formedness checker for parameterized non terminal application. *) - let actual_parameters_as_formal actual_parameters formal_parameters = - List.for_all2 (fun y -> (function ParameterVar x -> x.value = y - | _ -> false)) + let actual_parameters_as_formal actual_parameters formal_parameters = + List.for_all2 (fun y -> (function ParameterVar x -> x.value = y + | _ -> false)) formal_parameters actual_parameters in (* The environment is initialized. *) - let env : environment = StringMap.fold - (fun k r acu -> - (k, (r.pr_positions, nt_type (conv k))) + let env : environment = StringMap.fold + (fun k r acu -> + (k, (r.pr_positions, nt_type (conv k))) :: acu) 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 - - (* 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 - - (* 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 ()) + (* 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 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 + + (* 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 -> - (try - List.assoc x.value subst + (try + List.assoc x.value subst with Not_found -> - ParameterVar x) + ParameterVar x) - | ParameterApp (x, ps) -> - (try - match List.assoc x.value subst with - | ParameterVar y -> - ParameterApp (y, List.map (subst_parameter subst) ps) - - | ParameterApp _ -> - (* Type-checking ensures that we cannot do partial - application. Consequently, if an higher-order non terminal - is an actual argument, it cannot be the result of a - partial application. *) - assert false + | ParameterApp (x, ps) -> + (try + match List.assoc x.value subst with + | ParameterVar y -> + ParameterApp (y, List.map (subst_parameter subst) ps) + + | ParameterApp _ -> + (* Type-checking ensures that we cannot do partial + application. Consequently, if a higher-order nonterminal + is an actual argument, it cannot be the result of a + partial application. *) + assert false + + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false + + with Not_found -> + ParameterApp (x, List.map (subst_parameter subst) ps)) - with Not_found -> - ParameterApp (x, List.map (subst_parameter subst) ps)) + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false -let subst_parameters subst = + +let subst_parameters subst = List.map (subst_parameter subst) (* TEMPORARY why unused? -let names_of_p_grammar p_grammar = - StringMap.fold (fun tok _ acu -> StringSet.add tok acu) - p_grammar.p_tokens StringSet.empty +let names_of_p_grammar p_grammar = + StringMap.fold (fun tok _ acu -> StringSet.add tok acu) + p_grammar.p_tokens StringSet.empty $$ (StringMap.fold (fun nt _ acu -> StringSet.add nt acu) - p_grammar.p_rules) + p_grammar.p_rules) *) -let expand p_grammar = +let expand p_grammar = (* Check that it is safe to expand this parameterized grammar. *) check_grammar p_grammar; @@ -475,49 +504,54 @@ unique. *) let names = - ref (StringSet.empty) + ref (StringSet.empty) in let ensure_fresh name = let normalized_name = Misc.normalize name in if StringSet.mem normalized_name !names then Error.error [] - "internal name clash over %s" normalized_name; + "internal name clash over %s" normalized_name; names := StringSet.add normalized_name !names; name - in - let expanded_rules = - Hashtbl.create 13 in - let module InstanceTable = + let expanded_rules = + Hashtbl.create 13 + in + let module InstanceTable = Hashtbl.Make (Parameters) in - let rule_names = - InstanceTable.create 13 + let rule_names = + InstanceTable.create 13 in (* [mangle p] chooses a name for the new nonterminal symbol that corresponds to the parameter [p]. *) - let rec mangle = function + let rec mangle = function | ParameterVar x | ParameterApp (x, []) -> - Positions.value x + Positions.value x | ParameterApp (x, ps) -> - (* We include parentheses and commas in the names that we - assign to expanded nonterminals, because that is more - readable and acceptable in many situations. We replace them - with underscores in situations where these characters are - not valid. *) - - Printf.sprintf "%s(%s)" - (Positions.value x) - (separated_list_to_string mangle "," ps) + (* We include parentheses and commas in the names that we + assign to expanded nonterminals, because that is more + readable and acceptable in many situations. We replace them + with underscores in situations where these characters are + not valid. *) + + Printf.sprintf "%s(%s)" + (Positions.value x) + (separated_list_to_string mangle "," ps) + + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false + in - let name_of symbol parameters = + let name_of symbol parameters = let param = ParameterApp (symbol, parameters) in - try + try InstanceTable.find rule_names param with Not_found -> let name = ensure_fresh (mangle param) in @@ -526,34 +560,38 @@ in (* Given the substitution [subst] from parameters to non terminal, we instantiate the parameterized branch. *) - let rec expand_branch subst pbranch = - let new_producers = List.map + let rec expand_branch subst pbranch = + let new_producers = List.map (function (ido, p) -> - let sym, actual_parameters = - Parameters.unapp p in - let sym, actual_parameters = - try - match List.assoc sym.value subst with - | ParameterVar x -> - x, subst_parameters subst actual_parameters - - | ParameterApp (x, ps) -> - assert (actual_parameters = []); - x, ps - - with Not_found -> - sym, subst_parameters subst actual_parameters - in - (* Instantiate the definition of the producer. *) - (expand_branches subst sym actual_parameters, Positions.value ido)) + let sym, actual_parameters = + Parameters.unapp p in + let sym, actual_parameters = + try + match List.assoc sym.value subst with + | ParameterVar x -> + x, subst_parameters subst actual_parameters + + | ParameterApp (x, ps) -> + assert (actual_parameters = []); + x, ps + + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false + + with Not_found -> + sym, subst_parameters subst actual_parameters + in + (* Instantiate the definition of the producer. *) + (expand_branches subst sym actual_parameters, Positions.value ido)) pbranch.pr_producers in { branch_position = pbranch.pr_branch_position; - producers = new_producers; - action = pbranch.pr_action; - branch_prec_annotation = pbranch.pr_branch_prec_annotation; - branch_production_level = pbranch.pr_branch_production_level; + producers = new_producers; + action = pbranch.pr_action; + branch_prec_annotation = pbranch.pr_branch_prec_annotation; + branch_production_level = pbranch.pr_branch_production_level; } (* Instantiate the branches of sym for a particular set of actual @@ -561,28 +599,28 @@ and expand_branches subst sym actual_parameters = let nsym = name_of sym actual_parameters in try - if not (Hashtbl.mem expanded_rules nsym) then begin - let prule = StringMap.find (Positions.value sym) p_grammar.p_rules in - let subst = - (* Type checking ensures that parameterized non terminal - instantiations are well defined. *) - assert (List.length prule.pr_parameters - = List.length actual_parameters); - List.combine prule.pr_parameters actual_parameters @ subst in - Hashtbl.add expanded_rules nsym - { branches = []; positions = []; inline_flag = false }; - let rules = List.map (expand_branch subst) prule.pr_branches in - Hashtbl.replace expanded_rules nsym - { - branches = rules; - positions = prule.pr_positions; - inline_flag = prule.pr_inline_flag; - } - end; - nsym - (* If [sym] is a terminal, then it is not in [p_grammar.p_rules]. - Expansion is not needed. *) - with Not_found -> Positions.value sym + if not (Hashtbl.mem expanded_rules nsym) then begin + let prule = StringMap.find (Positions.value sym) p_grammar.p_rules in + let subst = + (* Type checking ensures that parameterized non terminal + instantiations are well defined. *) + assert (List.length prule.pr_parameters + = List.length actual_parameters); + List.combine prule.pr_parameters actual_parameters @ subst in + Hashtbl.add expanded_rules nsym + { branches = []; positions = []; inline_flag = false }; + let rules = List.map (expand_branch subst) prule.pr_branches in + Hashtbl.replace expanded_rules nsym + { + branches = rules; + positions = prule.pr_positions; + inline_flag = prule.pr_inline_flag; + } + end; + nsym + (* If [sym] is a terminal, then it is not in [p_grammar.p_rules]. + Expansion is not needed. *) + with Not_found -> Positions.value sym in (* Process %type declarations. *) @@ -602,48 +640,48 @@ 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 { preludes = p_grammar.p_preludes; - postludes = p_grammar.p_postludes; + postludes = p_grammar.p_postludes; 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 - (fun k prule rules -> - (* If [k] is a start symbol then it cannot be parameterized. *) - if prule.pr_parameters <> [] && StringSet.mem k start_symbols then - Error.error [] - "the start symbol %s cannot be parameterized." - k; - - (* Entry points are the closed non terminals. *) - if prule.pr_parameters = [] then - StringMap.add k { - branches = List.map (expand_branch []) prule.pr_branches; - positions = prule.pr_positions; - inline_flag = prule.pr_inline_flag; - } rules - else rules) - p_grammar.p_rules - StringMap.empty + tokens = p_grammar.p_tokens; + rules = + let closed_rules = StringMap.fold + (fun k prule rules -> + (* If [k] is a start symbol then it cannot be parameterized. *) + if prule.pr_parameters <> [] && StringSet.mem k start_symbols then + Error.error [] + "the start symbol %s cannot be parameterized." + k; + + (* Entry points are the closed non terminals. *) + if prule.pr_parameters = [] then + StringMap.add k { + branches = List.map (expand_branch []) prule.pr_branches; + positions = prule.pr_positions; + inline_flag = prule.pr_inline_flag; + } rules + else rules) + p_grammar.p_rules + StringMap.empty in - Hashtbl.fold StringMap.add expanded_rules closed_rules + Hashtbl.fold StringMap.add expanded_rules closed_rules } diff -Nru menhir-20151112.dfsg/src/parameterizedGrammar.mli menhir-20160808+dfsg/src/parameterizedGrammar.mli --- menhir-20151112.dfsg/src/parameterizedGrammar.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/parameterizedGrammar.mli 2016-08-08 19:19:04.000000000 +0000 @@ -10,6 +10,4 @@ sanitized via [Misc.normalize] when printed in a context where a valid identifier is expected. *) -val expand : InternalSyntax.grammar -> UnparameterizedSyntax.grammar - - +val expand : Syntax.grammar -> UnparameterizedSyntax.grammar diff -Nru menhir-20151112.dfsg/src/parameters.ml menhir-20160808+dfsg/src/parameters.ml --- menhir-20151112.dfsg/src/parameters.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/parameters.ml 2016-08-08 19:19:04.000000000 +0000 @@ -10,57 +10,62 @@ | _ -> ParameterApp (p, ps) -let oapp1 o p = - match o with - | None -> - p - | Some var -> - ParameterApp (var, [ p ]) - let unapp = function | ParameterVar x -> (x, []) - | ParameterApp (p, ps) -> (p, ps) + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false let rec map f = function | ParameterVar x -> ParameterVar (f x) - | ParameterApp (p, ps) -> ParameterApp (f p, List.map (map f) ps) - + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false let rec fold f init = function | ParameterVar x -> f init x - | ParameterApp (p, ps) -> f (List.fold_left (fold f) init ps) p - -let identifiers m p = - fold (fun acu x -> StringMap.add x.value x.position acu) m p + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false + +let identifiers m p = + fold (fun accu x -> StringMap.add x.value x.position accu) m p type t = parameter -let rec equal x y = +let rec equal x y = match x, y with - | ParameterVar x, ParameterVar y when x.value = y.value -> - true + | ParameterVar x, ParameterVar y -> + x.value = y.value | ParameterApp (p1, p2), ParameterApp (p1', p2') -> - p1.value = p1'.value && List.for_all2 equal p2 p2' - | _ -> false + p1.value = p1'.value && List.for_all2 equal p2 p2' + | _ -> + (* Anonymous rules are eliminated early on. *) + false let hash = function | ParameterVar x | ParameterApp (x, _) -> Hashtbl.hash (Positions.value x) + | ParameterAnonymous _ -> + (* Anonymous rules are eliminated early on. *) + assert false let position = function - | ParameterVar x + | ParameterVar x | ParameterApp (x, _) -> Positions.position x + | ParameterAnonymous bs -> + Positions.position bs let with_pos p = Positions.with_pos (position p) p diff -Nru menhir-20151112.dfsg/src/parserAux.ml menhir-20160808+dfsg/src/parserAux.ml --- menhir-20151112.dfsg/src/parserAux.ml 2015-11-12 20:02:03.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 = @@ -29,23 +34,23 @@ begin match right_hand_sides with | [] -> - assert false + assert false | (producers, _, _, _) :: right_hand_sides -> - let ids = defined_identifiers producers in - List.iter (fun (producers, _, _, _) -> - let ids' = defined_identifiers producers in - try - let id = - IdSet.choose (IdSet.union - (IdSet.diff ids ids') - (IdSet.diff ids' ids)) - in - Error.error [Positions.position id] - "two productions that share a semantic action must define\n\ - exactly the same identifiers." - with Not_found -> - () - ) right_hand_sides + let ids = defined_identifiers producers in + List.iter (fun (producers, _, _, _) -> + let ids' = defined_identifiers producers in + try + let id = + IdSet.choose (IdSet.union + (IdSet.diff ids ids') + (IdSet.diff ids' ids)) + in + Error.error [Positions.position id] + "two productions that share a semantic action must define\n\ + exactly the same identifiers." + with Not_found -> + () + ) right_hand_sides end (* [normalize_producer i p] assigns a name of the form [_i] @@ -71,42 +76,6 @@ | _, None -> o1 -(* Support for on-the-fly expansion of anonymous rules. Whenever such - a rule is encountered, we create a fresh non-terminal symbol, add - a definition of this symbol to a global variable, and return a - reference to this symbol. Quick and dirty. So, in the end, clean. *) - -let fresh : unit -> string = - let next = ref 0 in - fun () -> - Printf.sprintf "__anonymous_%d" (Misc.postincrement next) - -let rules = - ref [] - -let anonymous pos branches = - (* Generate a fresh non-terminal symbol. *) - let symbol = fresh() in - (* Construct its definition. Note that it is implicitly marked %inline. *) - let rule = { - pr_public_flag = false; - pr_inline_flag = true; - pr_nt = symbol; - pr_positions = [ pos ]; (* this list is not allowed to be empty *) - pr_parameters = []; - pr_branches = branches - } in - (* Record this definition. *) - rules := rule :: !rules; - (* Return the symbol that stands for it. *) - symbol - -let rules () = - let result = !rules in - (* Reset the global state, in case we need to read several .mly files. *) - rules := []; - result - (* Only unnamed producers can be referred to using positional identifiers. Besides, such positions must be taken in the interval [1 .. List.length producers]. The output array [p] is such that @@ -116,4 +85,3 @@ producers |> List.map (fun (_, oid, _) -> Option.map Positions.value oid) |> Array.of_list - diff -Nru menhir-20151112.dfsg/src/parserAux.mli menhir-20160808+dfsg/src/parserAux.mli --- menhir-20151112.dfsg/src/parserAux.mli 2015-11-12 20:02:03.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. *) @@ -36,7 +41,7 @@ A missing identifier in the [i]-th position receives the conventional name [_i]. *) -val normalize_producers: +val normalize_producers: (Positions.t * identifier Positions.located option * parameter) list -> producer list @@ -46,15 +51,6 @@ val override: Positions.t -> 'a option -> 'a option -> 'a option -(* Support for on-the-fly expansion of anonymous rules. When such a - rule is encountered, invoke [anonymous], which creates a fresh - non-terminal symbol, records the definition of this symbol to a - global variable, and returns this symbol. In the end, invoke - [rules], so as to obtain a list of all recorded definitions. *) - -val anonymous: Positions.t -> parameterized_branch list -> string -val rules: unit -> parameterized_rule list - (* [producer_names producers] returns an array [names] such that [names.(idx) = None] if the (idx + 1)-th producer is unnamed and [names.(idx) = Some id] if it is called [id]. *) diff -Nru menhir-20151112.dfsg/src/partialGrammar.ml menhir-20160808+dfsg/src/partialGrammar.ml --- menhir-20151112.dfsg/src/partialGrammar.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/partialGrammar.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,23 +1,21 @@ open Misc open Syntax -open ConcreteSyntax -open InternalSyntax open Positions (* ------------------------------------------------------------------------- *) (* This adds one declaration [decl], as found in file [filename], to the grammar [grammar]. *) -let join_declaration filename (grammar : grammar) decl = +let join_declaration filename (grammar : grammar) decl = match decl.value with (* Preludes are stored in an arbitrary order. The order of preludes within a single source file is preserved. Same treatment for functor parameters. *) - | DCode code -> + | DCode code -> { grammar with p_preludes = grammar.p_preludes @ [ code ] } - | DParameter (Stretch.Declared stretch) -> + | DParameter (Stretch.Declared stretch) -> { grammar with p_parameters = grammar.p_parameters @ [ stretch ] } | DParameter (Stretch.Inferred _) -> assert false @@ -27,49 +25,49 @@ declarations are independent. *) | DToken (ocamltype, terminal) -> - let token_property = - try + let token_property = + try - (* Retrieve any previous definition for this token. *) + (* Retrieve any previous definition for this token. *) - let token_property = - StringMap.find terminal grammar.p_tokens - in - - (* If the previous definition was actually a %token declaration - (as opposed to a %left, %right, or %nonassoc specification), - signal an error. *) - - if token_property.tk_is_declared then - Error.errorp decl - "the token %s has multiple definitions." terminal - - (* Otherwise, update the previous definition. *) - - else - { token_property with - tk_is_declared = true; - tk_ocamltype = ocamltype; - tk_filename = filename; - tk_position = decl.position; - } - - with Not_found -> - - (* If no previous definition exists, create one. *) - - { - tk_filename = filename; - tk_ocamltype = ocamltype; - tk_associativity = UndefinedAssoc; - tk_precedence = UndefinedPrecedence; - tk_position = decl.position; - tk_is_declared = true - } + let token_property = + StringMap.find terminal grammar.p_tokens + in + + (* If the previous definition was actually a %token declaration + (as opposed to a %left, %right, or %nonassoc specification), + signal an error. *) + + if token_property.tk_is_declared then + Error.errorp decl + "the token %s has multiple definitions." terminal + + (* Otherwise, update the previous definition. *) + + else + { token_property with + tk_is_declared = true; + tk_ocamltype = ocamltype; + tk_filename = filename; + tk_position = decl.position; + } + + with Not_found -> + + (* If no previous definition exists, create one. *) + + { + tk_filename = filename; + tk_ocamltype = ocamltype; + tk_associativity = UndefinedAssoc; + tk_precedence = UndefinedPrecedence; + tk_position = decl.position; + tk_is_declared = true + } in { grammar with - p_tokens = StringMap.add terminal token_property grammar.p_tokens } + p_tokens = StringMap.add terminal token_property grammar.p_tokens } (* Start symbols. *) @@ -85,41 +83,41 @@ (* 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. *) | DTokenProperties (terminal, assoc, prec) -> (* Retrieve the property record for this token, creating one - if none existed (but without deeming the token to have been - declared). *) + if none existed (but without deeming the token to have been + declared). *) - let token_properties, grammar = - try - StringMap.find terminal grammar.p_tokens, grammar - with Not_found -> - let p = { - tk_filename = filename; - tk_ocamltype = None; - tk_associativity = UndefinedAssoc; - tk_precedence = prec; - tk_is_declared = false; - (* Will be updated later. *) - tk_position = decl.position; - } in - p, { grammar with - p_tokens = StringMap.add terminal p grammar.p_tokens } + let token_properties, grammar = + try + StringMap.find terminal grammar.p_tokens, grammar + with Not_found -> + let p = { + tk_filename = filename; + tk_ocamltype = None; + tk_associativity = UndefinedAssoc; + tk_precedence = prec; + tk_is_declared = false; + (* Will be updated later. *) + tk_position = decl.position; + } in + p, { grammar with + p_tokens = StringMap.add terminal p grammar.p_tokens } in (* Reject duplicate precedence declarations. *) - if token_properties.tk_associativity <> UndefinedAssoc then - Error.error - [ decl.position; token_properties.tk_position ] - "there are multiple precedence declarations for token %s." terminal; + if token_properties.tk_associativity <> UndefinedAssoc then + Error.error + [ decl.position; token_properties.tk_position ] + "there are multiple precedence declarations for token %s." terminal; (* Record the new declaration. *) @@ -128,14 +126,14 @@ grammar (* ------------------------------------------------------------------------- *) -(* This stores an optional trailer into a grammar. +(* This stores an optional trailer into a grammar. Trailers are stored in an arbitrary order. *) -let join_trailer trailer grammar = +let join_trailer trailer grammar = match trailer with - | None -> - grammar - | Some trailer -> + | None -> + grammar + | Some trailer -> { grammar with p_postludes = trailer :: grammar.p_postludes } (* ------------------------------------------------------------------------- *) @@ -145,13 +143,13 @@ type renaming = (nonterminal * nonterminal) list -let identity_renaming = - [] +let identity_renaming = + [] let rewrite_nonterminal (phi : renaming) nonterminal = Misc.support_assoc phi nonterminal -let rewrite_parameter phi parameter = +let rewrite_parameter phi parameter = Parameters.map (Positions.map (Misc.support_assoc phi)) parameter let rewrite_element phi (ido, parameter) = @@ -167,18 +165,18 @@ | _ -> List.map (rewrite_branch phi) branches -let fresh_counter = ref 0 +let fresh_counter = ref 0 let names = ref StringSet.empty -let use_name name = +let use_name name = names := StringSet.add name !names -let used_name name = +let used_name name = StringSet.mem name !names -let rec fresh ?(hint = "v") () = - let name = +let rec fresh ?(hint = "v") () = + let name = incr fresh_counter; hint ^ string_of_int !fresh_counter in @@ -188,44 +186,44 @@ use_name name; name ) - + (* Alpha conversion of [prule]. We rename bound parameters using fresh names. *) -let alphaconvert_rule parameters prule = - let phi = +let alphaconvert_rule parameters prule = + let phi = List.combine parameters (List.map (fun x -> fresh ~hint:x ()) parameters) in { prule with - pr_parameters = List.map (Misc.support_assoc phi) prule.pr_parameters; - pr_branches = rewrite_branches phi prule.pr_branches + pr_parameters = List.map (Misc.support_assoc phi) prule.pr_parameters; + pr_branches = rewrite_branches phi prule.pr_branches } -(* Rewrite a rule taking bounded names into account. We rename parameters +(* Rewrite a rule taking bound names into account. We rename parameters to avoid capture. *) -let rewrite_rule phi prule = - let ids = - List.fold_left (fun acu (f, d) -> StringSet.add f (StringSet.add d acu)) - StringSet.empty phi +let rewrite_rule phi prule = + let ids = + List.fold_left (fun acu (f, d) -> StringSet.add f (StringSet.add d acu)) + StringSet.empty phi in - let captured_parameters = + let captured_parameters = List.filter (fun p -> StringSet.mem p ids) prule.pr_parameters in - let prule = + let prule = alphaconvert_rule captured_parameters prule in { prule with - pr_nt = rewrite_nonterminal phi prule.pr_nt; - pr_branches = rewrite_branches phi prule.pr_branches } - + pr_nt = rewrite_nonterminal phi prule.pr_nt; + pr_branches = rewrite_branches phi prule.pr_branches } + let rewrite_rules phi rules = List.map (rewrite_rule phi) rules let rewrite_grammar phi grammar = (* We assume that [phi] affects only private symbols, so it does not affect the start symbols. *) - if phi = identity_renaming then + if phi = identity_renaming then grammar - else + else { grammar with pg_rules = rewrite_rules phi grammar.pg_rules } (* ------------------------------------------------------------------------- *) @@ -233,7 +231,7 @@ This guarantees that names are unique. *) let is_valid_nonterminal_character = function - | 'A' .. 'Z' + | 'A' .. 'Z' | 'a' .. 'z' | '_' | '\192' .. '\214' @@ -252,11 +250,11 @@ done; Bytes.unsafe_to_string m -let rename nonterminal filename = +let rename nonterminal filename = let name = restrict filename ^ "_" ^ nonterminal in if used_name name then fresh ~hint:name () - else + else (use_name name; name) (* ------------------------------------------------------------------------- *) @@ -269,17 +267,17 @@ *) (* ------------------------------------------------------------------------- *) type symbol_kind = - + (* The nonterminal is declared public at a particular position. *) | PublicNonTerminal of Positions.t - (* The nonterminal is not declared public at a particular position. *) + (* The nonterminal is declared (nonpublic) at a particular position. *) | PrivateNonTerminal of Positions.t (* The symbol is a token. *) | Token of token_properties - (* We do not know yet what the symbol means. + (* We do not know yet what the symbol means. This is defined in the sequel or it is free in the partial grammar. *) | DontKnow of Positions.t @@ -301,62 +299,65 @@ let empty_symbol_table () : symbol_table = Hashtbl.create 13 -let store_symbol (symbols : symbol_table) symbol kind = +let store_symbol (symbols : symbol_table) symbol kind = try let sym_info = find_symbol symbols symbol in match sym_info, kind with - - (* There are two definitions of the same symbol in one - particular unit. This is forbidden. *) - | (PublicNonTerminal p | PrivateNonTerminal p), - (PublicNonTerminal p' | PrivateNonTerminal p') -> - Error.error [ p; p'] - "the nonterminal symbol %s is multiply defined." - symbol - - (* The symbol is known to be a token but declared as a non terminal.*) - | (Token tkp, (PrivateNonTerminal p | PublicNonTerminal p)) - | ((PrivateNonTerminal p | PublicNonTerminal p), Token tkp) -> - Error.error [ p; tkp.tk_position ] - "the identifier %s is a reference to a token." - symbol - - (* We do not gain any piece of information. *) - | _, DontKnow _ | Token _, Token _ -> - symbols - - (* We learn that the symbol is a non terminal or a token. *) - | DontKnow _, _ -> - replace_in_symbol_table symbols symbol kind + + (* There are two definitions of the same symbol in one + particular unit. This is forbidden. *) + | (PublicNonTerminal p | PrivateNonTerminal p), + (PublicNonTerminal p' | PrivateNonTerminal p') -> + Error.error [ p; p'] + "the nonterminal symbol %s is multiply defined." + symbol + + (* The symbol is known to be a token but declared as a nonterminal.*) + | (Token tkp, (PrivateNonTerminal p | PublicNonTerminal p)) + | ((PrivateNonTerminal p | PublicNonTerminal p), Token tkp) -> + Error.error [ p; tkp.tk_position ] + "the identifier %s is a reference to a token." + symbol + + (* We do not gain any piece of information. *) + | _, DontKnow _ | Token _, Token _ -> + symbols + + (* We learn that the symbol is a nonterminal or a token. *) + | DontKnow _, _ -> + replace_in_symbol_table symbols symbol kind with Not_found -> add_in_symbol_table symbols symbol kind let store_used_symbol position tokens symbols symbol = - try - store_symbol symbols symbol (Token (StringMap.find symbol tokens)) - with Not_found -> - store_symbol symbols symbol (DontKnow position) + let kind = + try + Token (StringMap.find symbol tokens) + with Not_found -> + DontKnow position + in + store_symbol symbols symbol kind -let non_terminal_is_not_reserved symbol positions = +let non_terminal_is_not_reserved symbol positions = if symbol = "error" then Error.error positions "%s is reserved and thus cannot be used \ as a non-terminal symbol." symbol -let non_terminal_is_not_a_token tokens symbol positions = +let non_terminal_is_not_a_token tokens symbol positions = try let tkp = StringMap.find symbol tokens in Error.error (positions @ [ tkp.tk_position ]) - "the identifier %s is a reference to a token." - symbol + "the identifier %s is a reference to a token." + symbol with Not_found -> () let store_public_nonterminal tokens symbols symbol positions = non_terminal_is_not_reserved symbol positions; non_terminal_is_not_a_token tokens symbol positions; store_symbol symbols symbol (PublicNonTerminal (List.hd positions)) - + let store_private_nonterminal tokens symbols symbol positions = non_terminal_is_not_reserved symbol positions; non_terminal_is_not_a_token tokens symbol positions; @@ -377,7 +378,7 @@ | DontKnow p -> Printf.sprintf "only used at (%s)" (Positions.string_of_pos p) -let string_of_symbol_table t = +let string_of_symbol_table t = let b = Buffer.create 13 in let m = 1 + Hashtbl.fold (fun k v acu -> max (String.length k) acu) t 0 in let fill_blank s = @@ -385,183 +386,176 @@ String.blit s 0 s' 0 (String.length s); s' in - Hashtbl.iter (fun k v -> Buffer.add_string b - (Printf.sprintf "%s: %s\n" - (fill_blank k) (string_of_kind v))) t; + Hashtbl.iter (fun k v -> Buffer.add_string b + (Printf.sprintf "%s: %s\n" + (fill_blank k) (string_of_kind v))) t; Buffer.contents b *) -let is_private_symbol t x = +let is_private_symbol t x = try match Hashtbl.find t x with | PrivateNonTerminal _ -> - true - + true | _ -> - false - with Not_found -> + false + with Not_found -> false (* TEMPORARY why unused? -let is_public_symbol t x = +let is_public_symbol t x = try match Hashtbl.find t x with | PublicNonTerminal _ -> - true - + true + | _ -> - false - with Not_found -> + false + with Not_found -> false *) -let fold_on_private_symbols f init t = - Hashtbl.fold +let fold_on_private_symbols f init t = + Hashtbl.fold (fun k -> function PrivateNonTerminal _ -> (fun acu -> f acu k) | _ -> (fun acu -> acu)) t init -let fold_on_public_symbols f init t = - Hashtbl.fold +let fold_on_public_symbols f init t = + Hashtbl.fold (fun k -> function PublicNonTerminal _ -> (fun acu -> f acu k) | _ -> (fun acu -> acu)) t init -let iter_on_only_used_symbols f t = - Hashtbl.iter +let iter_on_only_used_symbols f t = + Hashtbl.iter (fun k -> function DontKnow pos -> f k pos | _ -> ()) - t + t -let symbols_of grammar (pgrammar : ConcreteSyntax.grammar) = +let symbols_of grammar (pgrammar : Syntax.partial_grammar) = let tokens = grammar.p_tokens in - let symbols_of_rule symbols prule = - let rec store_except_rule_parameters = - fun symbols (symbol, parameters) -> - (* Rule parameters are bound locally, so they are not taken into - account. *) - if List.mem symbol.value prule.pr_parameters then - symbols - else - (* Otherwise, mark this symbol as being used and analyse its - parameters. *) - List.fold_left - (fun symbols -> function - | ParameterApp (symbol, parameters) -> - store_except_rule_parameters symbols (symbol, parameters) - | ParameterVar symbol -> - store_except_rule_parameters symbols (symbol, []) - ) - (store_used_symbol symbol.position tokens symbols symbol.value) parameters + let symbols_of_rule symbols prule = + let rec store_except_rule_parameters symbols parameter = + let symbol, parameters = Parameters.unapp parameter in + (* Process the reference to [symbol]. *) + let symbols = + if List.mem symbol.value prule.pr_parameters then + (* Rule parameters are bound locally, so they are not taken into account. *) + symbols + else + store_used_symbol symbol.position tokens symbols symbol.value + in + (* Process the parameters. *) + List.fold_left store_except_rule_parameters symbols parameters in - + (* Analyse each branch. *) let symbols = List.fold_left (fun symbols branch -> - List.fold_left (fun symbols (_, p) -> - let symbol, parameters = Parameters.unapp p in - store_except_rule_parameters symbols (symbol, parameters) + List.fold_left (fun symbols (_, p) -> + store_except_rule_parameters symbols p ) symbols branch.pr_producers ) symbols prule.pr_branches in (* Store the symbol declaration. *) - if prule.pr_public_flag - || StringMap.mem prule.pr_nt grammar.p_start_symbols then - store_public_nonterminal tokens symbols prule.pr_nt prule.pr_positions + if prule.pr_public_flag + || StringMap.mem prule.pr_nt grammar.p_start_symbols then + store_public_nonterminal tokens symbols prule.pr_nt prule.pr_positions else - store_private_nonterminal tokens symbols prule.pr_nt prule.pr_positions + store_private_nonterminal tokens symbols prule.pr_nt prule.pr_positions in List.fold_left symbols_of_rule (empty_symbol_table ()) pgrammar.pg_rules -let merge_rules symbols pgs = +let merge_rules symbols pgs = (* Retrieve all the public symbols. *) let public_symbols = - List.fold_left (fold_on_public_symbols (fun s k -> StringSet.add k s)) + List.fold_left (fold_on_public_symbols (fun s k -> StringSet.add k s)) (StringSet.singleton "error") symbols in - (* We check the references in each grammar can be bound to + (* We check the references in each grammar can be bound to a public symbol. *) - let _ = - List.iter - (iter_on_only_used_symbols - (fun k pos -> if not (StringSet.mem k public_symbols) then - Error.error [ pos ] - "%s is undefined." k)) + let _ = + List.iter + (iter_on_only_used_symbols + (fun k pos -> if not (StringSet.mem k public_symbols) then + Error.error [ pos ] + "%s is undefined." k)) symbols in (* Detect private symbol clashes and rename them if necessary. *) - let detect_private_symbol_clashes = - fold_on_private_symbols + let detect_private_symbol_clashes = + fold_on_private_symbols (fun (defined, clashes) symbol -> - if StringSet.mem symbol defined - || StringSet.mem symbol public_symbols then - (defined, StringSet.add symbol clashes) - else - (StringSet.add symbol defined, clashes)) - in - let _private_symbols, clashes = + if StringSet.mem symbol defined + || StringSet.mem symbol public_symbols then + (defined, StringSet.add symbol clashes) + else + (StringSet.add symbol defined, clashes)) + in + let _private_symbols, clashes = List.fold_left detect_private_symbol_clashes (StringSet.empty, StringSet.empty) symbols - in - let rpgs = List.map + in + let rpgs = List.map (fun (symbol_table, pg) -> - let renaming = - StringSet.fold - (fun x phi -> - if is_private_symbol symbol_table x then begin - let x' = rename x pg.pg_filename in - Printf.fprintf stderr - "Note: the nonterminal symbol %s (from %s) is renamed %s.\n" - x pg.pg_filename x'; - (x, x') :: phi - end - else phi) - clashes [] + let renaming = + StringSet.fold + (fun x phi -> + if is_private_symbol symbol_table x then begin + let x' = rename x pg.pg_filename in + Printf.fprintf stderr + "Note: the nonterminal symbol %s (from %s) is renamed %s.\n" + x pg.pg_filename x'; + (x, x') :: phi + end + else phi) + clashes [] in - rewrite_grammar renaming pg) + rewrite_grammar renaming pg) pgs in - - (* Merge public nonterminal definitions + + (* Merge public nonterminal definitions and copy private nonterminal definitions. Since the clash between private symbols have already been resolved, these copies are safe. *) - List.fold_left - (fun rules rpg -> List.fold_left - (fun rules r -> - let r = - try - let r' = StringMap.find r.pr_nt rules in - let positions = r.pr_positions @ r'.pr_positions in - let ra, ra' = - List.length r.pr_parameters, - List.length r'.pr_parameters - in - (* The arity of the parameterized symbols must be constant.*) - if ra <> ra' then - Error.error positions - "the symbol %s is defined with arities %d and %d." - r.pr_nt ra ra' - else if r.pr_inline_flag <> r'.pr_inline_flag then - Error.error positions - "not all definitions of %s are marked %%inline." r.pr_nt - else - (* We combine the different branches. The parameters - could have different names, we rename them with - the fresh names assigned earlier (see the next - comment). *) - let phi = List.combine r.pr_parameters r'.pr_parameters in - let rbr = rewrite_branches phi r.pr_branches in - { r' with - pr_positions = positions; - pr_branches = rbr @ r'.pr_branches - } - with Not_found -> - (* We alphaconvert the rule in order to avoid the capture of - private symbols coming from another unit. *) - alphaconvert_rule r.pr_parameters r - in - StringMap.add r.pr_nt r rules) rules rpg.pg_rules) + List.fold_left + (fun rules rpg -> List.fold_left + (fun rules r -> + let r = + try + let r' = StringMap.find r.pr_nt rules in + let positions = r.pr_positions @ r'.pr_positions in + let ra, ra' = + List.length r.pr_parameters, + List.length r'.pr_parameters + in + (* The arity of the parameterized symbols must be constant.*) + if ra <> ra' then + Error.error positions + "the symbol %s is defined with arities %d and %d." + r.pr_nt ra ra' + else if r.pr_inline_flag <> r'.pr_inline_flag then + Error.error positions + "not all definitions of %s are marked %%inline." r.pr_nt + else + (* We combine the different branches. The parameters + could have different names, we rename them with + the fresh names assigned earlier (see the next + comment). *) + let phi = List.combine r.pr_parameters r'.pr_parameters in + let rbr = rewrite_branches phi r.pr_branches in + { r' with + pr_positions = positions; + pr_branches = rbr @ r'.pr_branches + } + with Not_found -> + (* We alphaconvert the rule in order to avoid the capture of + private symbols coming from another unit. *) + alphaconvert_rule r.pr_parameters r + in + StringMap.add r.pr_nt r rules) rules rpg.pg_rules) StringMap.empty rpgs let empty_grammar = @@ -584,91 +578,97 @@ let check_parameterized_grammar_is_well_defined grammar = (* Every start symbol is defined and has a %type declaration. *) - StringMap.iter + StringMap.iter (fun nonterminal p -> if not (StringMap.mem nonterminal grammar.p_rules) then - Error.error [p] "the start symbol %s is undefined." nonterminal; - if not (List.exists (function + Error.error [p] "the start symbol %s is undefined." nonterminal; + if not (List.exists (function | ParameterVar { value = id }, _ -> id = nonterminal | _ -> false) grammar.p_types) then - Error.error [p] - "the type of the start symbol %s is unspecified." nonterminal; + Error.error [p] + "the type of the start symbol %s is unspecified." nonterminal; ) grammar.p_start_symbols; - let parameter_head_symb = function - | ParameterVar id -> id - | ParameterApp (id, _) -> id - in - - (* 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 = parameter_head_symb 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 = + let mark_token_as_used token = used_tokens := StringSet.add token !used_tokens in - let check_identifier_reference grammar prule s p = + let check_identifier_reference grammar prule s p = (* Mark the symbol as a used token if this is a token. *) if StringMap.mem s grammar.p_tokens then mark_token_as_used s; - + if not (StringMap.mem s grammar.p_rules - || StringMap.mem s grammar.p_tokens - || List.mem s prule.pr_parameters - || List.mem s reserved) then + || StringMap.mem s grammar.p_tokens + || List.mem s prule.pr_parameters + || List.mem s reserved) then Error.error [ p ] "%s is undefined." s in StringMap.iter (fun k prule -> List.iter - (* Check each branch. *) - (fun { pr_producers = producers; - pr_branch_prec_annotation; - } -> ignore (List.fold_left + (* Check each branch. *) + (fun { pr_producers = producers; + pr_branch_prec_annotation; + } -> ignore (List.fold_left - (* Check the producers. *) + (* Check the producers. *) (fun already_seen (id, p) -> - let symbol, parameters = Parameters.unapp p in - let s = symbol.value and p = symbol.position in - let already_seen = - (* Check the producer id is unique. *) - if StringSet.mem id.value already_seen then - Error.error [ id.position ] - "there are multiple producers named %s in this sequence." - id.value; - StringSet.add id.value already_seen - in - - (* Check that the producer is defined somewhere. *) - check_identifier_reference grammar prule s p; - StringMap.iter (check_identifier_reference grammar prule) - (List.fold_left Parameters.identifiers StringMap.empty parameters); + let symbol, parameters = Parameters.unapp p in + let s = symbol.value and p = symbol.position in + let already_seen = + (* Check the producer id is unique. *) + if StringSet.mem id.value already_seen then + Error.error [ id.position ] + "there are multiple producers named %s in this sequence." + id.value; + StringSet.add id.value already_seen + in + + (* Check that the producer is defined somewhere. *) + check_identifier_reference grammar prule s p; + StringMap.iter (check_identifier_reference grammar prule) + (List.fold_left Parameters.identifiers StringMap.empty parameters); - (* If this producer seems to be a reference to a token, make sure it + (* If this producer seems to be a reference to a token, make sure it is a real token, as opposed to a pseudo-token introduced in a priority declaration. *) - (try + (try if not ((StringMap.find s grammar.p_tokens).tk_is_declared - || List.mem s reserved) then - Error.errorp symbol - "%s has not been declared as a token." s - with Not_found -> ()); - already_seen + || List.mem s reserved) then + Error.errorp symbol + "%s has not been declared as a token." s + with Not_found -> ()); + already_seen ) StringSet.empty producers); @@ -677,30 +677,25 @@ | None -> () | Some terminal -> - check_identifier_reference grammar prule - terminal.value terminal.position; + check_identifier_reference grammar prule + terminal.value terminal.position; - (* It is forbidden to use the %prec directive with %inline. *) - if prule.pr_inline_flag then - Error.errorp terminal - "use of %%prec is forbidden in an %%inlined nonterminal definition."; - - (* Furthermore, the symbol following %prec must be a valid - token identifier. *) + (* Furthermore, the symbol following %prec must be a valid + token identifier. *) if not (StringMap.mem terminal.value grammar.p_tokens) then - Error.errorp terminal - "%s is undefined." terminal.value) + Error.errorp terminal + "%s is undefined." terminal.value) - prule.pr_branches; + prule.pr_branches; - (* It is forbidden to use %inline on a %start symbol. *) - if (prule.pr_inline_flag - && StringMap.mem k grammar.p_start_symbols) then - Error.error prule.pr_positions - "%s cannot be both a start symbol and inlined." k; + (* It is forbidden to use %inline on a %start symbol. *) + if (prule.pr_inline_flag + && StringMap.mem k grammar.p_start_symbols) then + Error.error prule.pr_positions + "%s cannot be both a start symbol and inlined." k; ) grammar.p_rules; - + (* Check that every token is used. *) if not Settings.ignore_all_unused_tokens then begin match Settings.token_type_mode with @@ -708,19 +703,19 @@ () | Settings.TokenTypeAndCode | Settings.CodeOnly _ -> - StringMap.iter (fun token { tk_position = p } -> + StringMap.iter (fun token { tk_position = p } -> if not (StringSet.mem token !used_tokens || StringSet.mem token Settings.ignored_unused_tokens) then - Error.warning [p] + Error.warning [p] "the token %s is unused." token ) grammar.p_tokens end; - + grammar let join_partial_grammars pgs = let grammar = List.fold_left join empty_grammar pgs in let symbols = List.map (symbols_of grammar) pgs in let tpgs = List.combine symbols pgs in - let rules = merge_rules symbols tpgs in + let rules = merge_rules symbols tpgs in check_parameterized_grammar_is_well_defined { grammar with p_rules = rules } diff -Nru menhir-20151112.dfsg/src/partialGrammar.mli menhir-20160808+dfsg/src/partialGrammar.mli --- menhir-20151112.dfsg/src/partialGrammar.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/partialGrammar.mli 2016-08-08 19:19:04.000000000 +0000 @@ -1,2 +1,4 @@ -val join_partial_grammars : - ConcreteSyntax.grammar list -> InternalSyntax.grammar +open Syntax + +val join_partial_grammars : + partial_grammar list -> grammar diff -Nru menhir-20151112.dfsg/src/patricia.ml menhir-20160808+dfsg/src/patricia.ml --- menhir-20151112.dfsg/src/patricia.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/patricia.ml 2016-08-08 19:19:04.000000000 +0000 @@ -77,9 +77,9 @@ let rec highest_bit x = let m = lowest_bit x in if x = m then - m + m else - highest_bit (x - m) + highest_bit (x - m) (* Performing a logical ``xor'' of [i0] and [i1] yields a bit field where all differences between [i0] and [i1] show up as one bits. (There must be at least one, since [i0] and [i1] are distinct.) The ``first'' one is @@ -139,11 +139,11 @@ let rec choose = function | Empty -> - raise Not_found + raise Not_found | Leaf (key, data) -> - key, data + key, data | Branch (_, _, tree0, _) -> - choose tree0 + choose tree0 (* [lookup k m] looks up the value associated to the key [k] in the map [m], and raises [Not_found] if no value is bound to [k]. @@ -155,14 +155,14 @@ let rec lookup key = function | Empty -> - raise Not_found + raise Not_found | Leaf (key', data) -> - if key = key' then - data - else - raise Not_found + if key = key' then + data + else + raise Not_found | Branch (_, mask, tree0, tree1) -> - lookup key (if (key land mask) = 0 then tree0 else tree1) + lookup key (if (key land mask) = 0 then tree0 else tree1) let find = lookup @@ -216,23 +216,23 @@ let rec add t = match t with - | Empty -> - Leaf (k, d) - | Leaf (k0, d0) -> - if k = k0 then - let d' = decide d0 d in - if d' == d0 then - raise Unchanged - else - Leaf (k, d') - else - join k (Leaf (k, d)) k0 t - | Branch (p, m, t0, t1) -> - if match_prefix k p m then - if (k land m) = 0 then Branch (p, m, add t0, t1) - else Branch (p, m, t0, add t1) - else - join k (Leaf (k, d)) p t in + | Empty -> + Leaf (k, d) + | Leaf (k0, d0) -> + if k = k0 then + let d' = decide d0 d in + if d' == d0 then + raise Unchanged + else + Leaf (k, d') + else + join k (Leaf (k, d)) k0 t + | Branch (p, m, t0, t1) -> + if match_prefix k p m then + if (k land m) = 0 then Branch (p, m, add t0, t1) + else Branch (p, m, t0, add t1) + else + join k (Leaf (k, d)) p t in add m @@ -261,30 +261,30 @@ let is_singleton = function | Leaf (k, d) -> - Some (k, d) + Some (k, d) | Empty | Branch _ -> - None + None (* [is_empty m] returns [true] if and only if the map [m] defines no bindings at all. *) let is_empty = function | Empty -> - true + true | Leaf _ | Branch _ -> - false + false (* [cardinal m] returns [m]'s cardinal, that is, the number of keys it binds, or, in other words, its domain's cardinal. *) let rec cardinal = function | Empty -> - 0 + 0 | Leaf _ -> - 1 + 1 | Branch (_, _, t0, t1) -> - cardinal t0 + cardinal t1 + cardinal t0 + cardinal t1 (* [remove k m] returns the map [m] deprived from any binding involving [k]. *) @@ -292,25 +292,25 @@ let rec remove = function | Empty -> - raise Not_found + raise Not_found | Leaf (key', _) -> - if key = key' then - Empty - else - raise Not_found + if key = key' then + Empty + else + raise Not_found | Branch (prefix, mask, tree0, tree1) -> - if (key land mask) = 0 then - match remove tree0 with - | Empty -> - tree1 - | tree0 -> - Branch (prefix, mask, tree0, tree1) - else - match remove tree1 with - | Empty -> - tree0 - | tree1 -> - Branch (prefix, mask, tree0, tree1) in + if (key land mask) = 0 then + match remove tree0 with + | Empty -> + tree1 + | tree0 -> + Branch (prefix, mask, tree0, tree1) + else + match remove tree1 with + | Empty -> + tree0 + | tree1 -> + Branch (prefix, mask, tree0, tree1) in try remove m @@ -323,25 +323,25 @@ let rec lookup_and_remove key = function | Empty -> - raise Not_found + raise Not_found | Leaf (key', data) -> - if key = key' then - data, Empty - else - raise Not_found + if key = key' then + data, Empty + else + raise Not_found | Branch (prefix, mask, tree0, tree1) -> - if (key land mask) = 0 then - match lookup_and_remove key tree0 with - | data, Empty -> - data, tree1 - | data, tree0 -> - data, Branch (prefix, mask, tree0, tree1) - else - match lookup_and_remove key tree1 with - | data, Empty -> - data, tree0 - | data, tree1 -> - data, Branch (prefix, mask, tree0, tree1) + if (key land mask) = 0 then + match lookup_and_remove key tree0 with + | data, Empty -> + data, tree1 + | data, tree0 -> + data, Branch (prefix, mask, tree0, tree1) + else + match lookup_and_remove key tree1 with + | data, Empty -> + data, tree0 + | data, tree1 -> + data, Branch (prefix, mask, tree0, tree1) let find_and_remove = lookup_and_remove @@ -360,54 +360,54 @@ let rec union s t = match s, t with - - | Empty, _ -> - t + + | Empty, _ -> + t | (Leaf _ | Branch _), Empty -> - s + s | Leaf(key, value), _ -> - fine_add (reverse decide) key value t + fine_add (reverse decide) key value t | Branch _, Leaf(key, value) -> - fine_add decide key value s + fine_add decide key value s | Branch(p, m, s0, s1), Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then + if (p = q) && (m = n) then - (* The trees have the same prefix. Merge their sub-trees. *) + (* The trees have the same prefix. Merge their sub-trees. *) - let u0 = union s0 t0 - and u1 = union s1 t1 in - if t0 == u0 && t1 == u1 then t - else Branch(p, m, u0, u1) + let u0 = union s0 t0 + and u1 = union s1 t1 in + if t0 == u0 && t1 == u1 then t + else Branch(p, m, u0, u1) - else if (X.shorter m n) && (match_prefix q p m) then + else if (X.shorter m n) && (match_prefix q p m) then - (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) + (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) - if (q land m) = 0 then - Branch(p, m, union s0 t, s1) - else - Branch(p, m, s0, union s1 t) + if (q land m) = 0 then + Branch(p, m, union s0 t, s1) + else + Branch(p, m, s0, union s1 t) - else if (X.shorter n m) && (match_prefix p q n) then + else if (X.shorter n m) && (match_prefix p q n) then - (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) + (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) - if (p land n) = 0 then - let u0 = union s t0 in - if t0 == u0 then t - else Branch(q, n, u0, t1) - else - let u1 = union s t1 in - if t1 == u1 then t - else Branch(q, n, t0, u1) + if (p land n) = 0 then + let u0 = union s t0 in + if t0 == u0 then t + else Branch(q, n, u0, t1) + else + let u1 = union s t1 in + if t1 == u1 then t + else Branch(q, n, t0, u1) - else + else - (* The prefixes disagree. *) + (* The prefixes disagree. *) - join p s q t in + join p s q t in union m1 m2 @@ -422,12 +422,12 @@ let rec iter f = function | Empty -> - () + () | Leaf (key, data) -> - f key data + f key data | Branch (_, _, tree0, tree1) -> - iter f tree0; - iter f tree1 + iter f tree0; + iter f tree1 (* [fold f m seed] invokes [f k d accu], in turn, for each binding from key [k] to datum [d] in the map [m]. Keys are presented to [f] in increasing order according to the map's ordering. The initial value of @@ -437,22 +437,22 @@ let rec fold f m accu = match m with | Empty -> - accu + accu | Leaf (key, data) -> - f key data accu + f key data accu | Branch (_, _, tree0, tree1) -> - fold f tree1 (fold f tree0 accu) + fold f tree1 (fold f tree0 accu) (* [fold_rev] performs exactly the same job as [fold], but presents keys to [f] in the opposite order. *) let rec fold_rev f m accu = match m with | Empty -> - accu + accu | Leaf (key, data) -> - f key data accu + f key data accu | Branch (_, _, tree0, tree1) -> - fold_rev f tree0 (fold_rev f tree1 accu) + fold_rev f tree0 (fold_rev f tree1 accu) (* It is valid to evaluate [iter2 f m1 m2] if and only if [m1] and [m2] have the same domain. Doing so invokes [f k x1 x2], in turn, for each key [k] bound to [x1] in [m1] and to [x2] in [m2]. Bindings are presented to [f] @@ -461,28 +461,28 @@ let rec iter2 f t1 t2 = match t1, t2 with | Empty, Empty -> - () + () | Leaf (key1, data1), Leaf (key2, data2) -> - assert (key1 = key2); - f key1 (* for instance *) data1 data2 + assert (key1 = key2); + f key1 (* for instance *) data1 data2 | Branch (p1, m1, left1, right1), Branch (p2, m2, left2, right2) -> - assert (p1 = p2); - assert (m1 = m2); - iter2 f left1 left2; - iter2 f right1 right2 + assert (p1 = p2); + assert (m1 = m2); + iter2 f left1 left2; + iter2 f right1 right2 | _, _ -> - assert false + assert false (* [map f m] returns the map obtained by composing the map [m] with the function [f]; that is, the map $k\mapsto f(m(k))$. *) let rec map f = function | Empty -> - Empty + Empty | Leaf (key, data) -> - Leaf(key, f data) + Leaf(key, f data) | Branch (p, m, tree0, tree1) -> - Branch (p, m, map f tree0, map f tree1) + Branch (p, m, map f tree0, map f tree1) (* [endo_map] is similar to [map], but attempts to physically share its result with its input. This saves memory when [f] is the identity function. *) @@ -490,20 +490,20 @@ let rec endo_map f tree = match tree with | Empty -> - tree + tree | Leaf (key, data) -> - let data' = f data in - if data == data' then - tree - else - Leaf(key, data') + let data' = f data in + if data == data' then + tree + else + Leaf(key, data') | Branch (p, m, tree0, tree1) -> - let tree0' = endo_map f tree0 in - let tree1' = endo_map f tree1 in - if (tree0' == tree0) && (tree1' == tree1) then - tree - else - Branch (p, m, tree0', tree1') + let tree0' = endo_map f tree0 in + let tree1' = endo_map f tree1 in + if (tree0' == tree0) && (tree1' == tree1) then + tree + else + Branch (p, m, tree0', tree1') (* [filter f m] returns a copy of the map [m] where only the bindings that satisfy [f] have been retained. *) @@ -527,16 +527,16 @@ let rec next () = match !remainder with | [] -> - None + None | Empty :: parent -> - remainder := parent; - next() + remainder := parent; + next() | (Leaf (key, data)) :: parent -> - remainder := parent; - Some (key, data) + remainder := parent; + Some (key, data) | (Branch(_, _, s0, s1)) :: parent -> - remainder := s0 :: s1 :: parent; - next () in + remainder := s0 :: s1 :: parent; + next () in next @@ -549,23 +549,23 @@ let iterator2 = iterator m2 in try iter (fun key1 data1 -> - match iterator2() with - | None -> - raise (Got 1) - | Some (key2, data2) -> - let c = Pervasives.compare key1 key2 in - if c <> 0 then - raise (Got c) - else - let c = dcompare data1 data2 in - if c <> 0 then - raise (Got c) + match iterator2() with + | None -> + raise (Got 1) + | Some (key2, data2) -> + let c = Pervasives.compare key1 key2 in + if c <> 0 then + raise (Got c) + else + let c = dcompare data1 data2 in + if c <> 0 then + raise (Got c) ) m1; match iterator2() with | None -> - 0 + 0 | Some _ -> - -1 + -1 with Got c -> c @@ -594,10 +594,10 @@ let is_empty = function | Empty -> - true + true | Leaf _ | Branch _ -> - false + false (* [singleton x] returns a set whose only element is [x]. *) @@ -618,31 +618,31 @@ let rec choose = function | Empty -> - raise Not_found + raise Not_found | Leaf x -> - x + x | Branch (_, _, tree0, _) -> - choose tree0 + choose tree0 (* [cardinal s] returns [s]'s cardinal. *) let rec cardinal = function | Empty -> - 0 + 0 | Leaf _ -> - 1 + 1 | Branch (_, _, t0, t1) -> - cardinal t0 + cardinal t1 + cardinal t0 + cardinal t1 (* [mem x s] returns [true] if and only if [x] appears in the set [s]. *) let rec mem x = function | Empty -> - false + false | Leaf x' -> - x = x' + x = x' | Branch (_, mask, tree0, tree1) -> - mem x (if (x land mask) = 0 then tree0 else tree1) + mem x (if (x land mask) = 0 then tree0 else tree1) (* The auxiliary function [join] merges two trees in the simple case where their prefixes disagree. *) @@ -661,18 +661,18 @@ let rec strict_add x t = match t with | Empty -> - Leaf x + Leaf x | Leaf x0 -> - if x = x0 then - raise Unchanged - else - join x (Leaf x) x0 t + if x = x0 then + raise Unchanged + else + join x (Leaf x) x0 t | Branch (p, m, t0, t1) -> - if match_prefix x p m then - if (x land m) = 0 then Branch (p, m, strict_add x t0, t1) - else Branch (p, m, t0, strict_add x t1) - else - join x (Leaf x) p t + if match_prefix x p m then + if (x land m) = 0 then Branch (p, m, strict_add x t0, t1) + else Branch (p, m, t0, strict_add x t1) + else + join x (Leaf x) p t let add x s = try @@ -686,25 +686,25 @@ let rec strict_remove = function | Empty -> - raise Not_found + raise Not_found | Leaf x' -> - if x = x' then - Empty - else - raise Not_found + if x = x' then + Empty + else + raise Not_found | Branch (prefix, mask, tree0, tree1) -> - if (x land mask) = 0 then - match strict_remove tree0 with - | Empty -> - tree1 - | tree0 -> - Branch (prefix, mask, tree0, tree1) - else - match strict_remove tree1 with - | Empty -> - tree0 - | tree1 -> - Branch (prefix, mask, tree0, tree1) in + if (x land mask) = 0 then + match strict_remove tree0 with + | Empty -> + tree1 + | tree0 -> + Branch (prefix, mask, tree0, tree1) + else + match strict_remove tree1 with + | Empty -> + tree0 + | tree1 -> + Branch (prefix, mask, tree0, tree1) in try strict_remove s @@ -717,66 +717,66 @@ match s, t with | Empty, _ -> - t + t | _, Empty -> - s + s | Leaf x, _ -> - add x t + add x t | _, Leaf x -> - add x s + add x s | Branch(p, m, s0, s1), Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then + if (p = q) && (m = n) then - (* The trees have the same prefix. Merge their sub-trees. *) + (* The trees have the same prefix. Merge their sub-trees. *) - let u0 = union s0 t0 - and u1 = union s1 t1 in - if t0 == u0 && t1 == u1 then t - else Branch(p, m, u0, u1) + let u0 = union s0 t0 + and u1 = union s1 t1 in + if t0 == u0 && t1 == u1 then t + else Branch(p, m, u0, u1) - else if (X.shorter m n) && (match_prefix q p m) then + else if (X.shorter m n) && (match_prefix q p m) then - (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) + (* [q] contains [p]. Merge [t] with a sub-tree of [s]. *) - if (q land m) = 0 then - Branch(p, m, union s0 t, s1) - else - Branch(p, m, s0, union s1 t) + if (q land m) = 0 then + Branch(p, m, union s0 t, s1) + else + Branch(p, m, s0, union s1 t) - else if (X.shorter n m) && (match_prefix p q n) then + else if (X.shorter n m) && (match_prefix p q n) then - (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) + (* [p] contains [q]. Merge [s] with a sub-tree of [t]. *) - if (p land n) = 0 then - let u0 = union s t0 in - if t0 == u0 then t - else Branch(q, n, u0, t1) - else - let u1 = union s t1 in - if t1 == u1 then t - else Branch(q, n, t0, u1) + if (p land n) = 0 then + let u0 = union s t0 in + if t0 == u0 then t + else Branch(q, n, u0, t1) + else + let u1 = union s t1 in + if t1 == u1 then t + else Branch(q, n, t0, u1) - else + else - (* The prefixes disagree. *) + (* The prefixes disagree. *) - join p s q t + join p s q t (* [build] is a ``smart constructor''. It builds a [Branch] node with the specified arguments, but ensures that the newly created node does not have an [Empty] child. *) let build p m t0 t1 = match t0, t1 with - | Empty, Empty -> - Empty - | Empty, _ -> - t1 - | _, Empty -> - t0 - | _, _ -> - Branch(p, m, t0, t1) + | Empty, Empty -> + Empty + | Empty, _ -> + t1 + | _, Empty -> + t0 + | _, _ -> + Branch(p, m, t0, t1) (* [inter s t] returns the set intersection of [s] and [t], that is, $s\cap t$. *) @@ -785,36 +785,36 @@ | Empty, _ | _, Empty -> - Empty + Empty | (Leaf x as s), t | t, (Leaf x as s) -> - if mem x t then s else Empty + if mem x t then s else Empty | Branch(p, m, s0, s1), Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then + if (p = q) && (m = n) then - (* The trees have the same prefix. Compute the intersections of their sub-trees. *) + (* The trees have the same prefix. Compute the intersections of their sub-trees. *) - build p m (inter s0 t0) (inter s1 t1) + build p m (inter s0 t0) (inter s1 t1) - else if (X.shorter m n) && (match_prefix q p m) then + else if (X.shorter m n) && (match_prefix q p m) then - (* [q] contains [p]. Intersect [t] with a sub-tree of [s]. *) + (* [q] contains [p]. Intersect [t] with a sub-tree of [s]. *) - inter (if (q land m) = 0 then s0 else s1) t + inter (if (q land m) = 0 then s0 else s1) t - else if (X.shorter n m) && (match_prefix p q n) then + else if (X.shorter n m) && (match_prefix p q n) then - (* [p] contains [q]. Intersect [s] with a sub-tree of [t]. *) + (* [p] contains [q]. Intersect [s] with a sub-tree of [t]. *) - inter s (if (p land n) = 0 then t0 else t1) + inter s (if (p land n) = 0 then t0 else t1) - else + else - (* The prefixes disagree. *) + (* The prefixes disagree. *) - Empty + Empty (* [disjoint s1 s2] returns [true] if and only if the sets [s1] and [s2] are disjoint, i.e. iff their intersection is empty. It is a specialized version of [inter], which uses less space. *) @@ -828,26 +828,26 @@ | Empty, _ | _, Empty -> - () + () | Leaf x, _ -> - if mem x t then - raise NotDisjoint + if mem x t then + raise NotDisjoint | _, Leaf x -> - if mem x s then - raise NotDisjoint + if mem x s then + raise NotDisjoint | Branch(p, m, s0, s1), Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then begin - inter s0 t0; - inter s1 t1 - end - else if (X.shorter m n) && (match_prefix q p m) then - inter (if (q land m) = 0 then s0 else s1) t - else if (X.shorter n m) && (match_prefix p q n) then - inter s (if (p land n) = 0 then t0 else t1) - else - () in + if (p = q) && (m = n) then begin + inter s0 t0; + inter s1 t1 + end + else if (X.shorter m n) && (match_prefix q p m) then + inter (if (q land m) = 0 then s0 else s1) t + else if (X.shorter n m) && (match_prefix p q n) then + inter s (if (p land n) = 0 then t0 else t1) + else + () in try inter s t; @@ -860,12 +860,12 @@ let rec iter f = function | Empty -> - () + () | Leaf x -> - f x + f x | Branch (_, _, tree0, tree1) -> - iter f tree0; - iter f tree1 + iter f tree0; + iter f tree1 (* [fold f s seed] invokes [f x accu], in turn, for each element [x] of the set [s]. Elements are presented to [f] according to some unspecified, but fixed, order. The initial value of [accu] is [seed]; then, at each new call, @@ -875,12 +875,12 @@ let rec fold f s accu = match s with - | Empty -> - accu - | Leaf x -> - f x accu - | Branch (_, _, s0, s1) -> - fold f s1 (fold f s0 accu) + | Empty -> + accu + | Leaf x -> + f x accu + | Branch (_, _, s0, s1) -> + fold f s1 (fold f s0 accu) (* [elements s] is a list of all elements in the set [s]. *) @@ -901,16 +901,16 @@ let rec next () = match !remainder with | [] -> - None + None | Empty :: parent -> - remainder := parent; - next() + remainder := parent; + next() | (Leaf x) :: parent -> - remainder := parent; - Some x + remainder := parent; + Some x | (Branch(_, _, s0, s1)) :: parent -> - remainder := s0 :: s1 :: parent; - next () in + remainder := s0 :: s1 :: parent; + next () in next @@ -922,19 +922,19 @@ let iterator2 = iterator s2 in try iter (fun x1 -> - match iterator2() with - | None -> - raise (Got 1) - | Some x2 -> - let c = Pervasives.compare x1 x2 in - if c <> 0 then - raise (Got c) + match iterator2() with + | None -> + raise (Got 1) + | Some x2 -> + let c = Pervasives.compare x1 x2 in + if c <> 0 then + raise (Got c) ) s1; match iterator2() with | None -> - 0 + 0 | Some _ -> - -1 + -1 with Got c -> c @@ -954,33 +954,33 @@ match s, t with | Empty, _ -> - () + () | _, Empty | Branch _, Leaf _ -> - raise NotSubset + raise NotSubset | Leaf x, _ -> - if not (mem x t) then - raise NotSubset + if not (mem x t) then + raise NotSubset | Branch(p, m, s0, s1), Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then begin + if (p = q) && (m = n) then begin - diff s0 t0; - diff s1 t1 + diff s0 t0; + diff s1 t1 - end - else if (X.shorter n m) && (match_prefix p q n) then + end + else if (X.shorter n m) && (match_prefix p q n) then - diff s (if (p land n) = 0 then t0 else t1) + diff s (if (p land n) = 0 then t0 else t1) - else + else - (* Either [q] contains [p], which means at least one of [s]'s sub-trees is not contained within [t], - or the prefixes disagree. In either case, the subset relationship cannot possibly hold. *) + (* Either [q] contains [p], which means at least one of [s]'s sub-trees is not contained within [t], + or the prefixes disagree. In either case, the subset relationship cannot possibly hold. *) - raise NotSubset in + raise NotSubset in try diff s t; @@ -995,25 +995,25 @@ (* Back to the world of maps. Let us now describe the relationship which exists between maps and their domains. *) - (* [domain m] returns [m]'s domain. *) + (* [domain m] returns [m]'s domain. *) let rec domain = function | Empty -> - Domain.Empty + Domain.Empty | Leaf (k, _) -> - Domain.Leaf k + Domain.Leaf k | Branch (p, m, t0, t1) -> - Domain.Branch (p, m, domain t0, domain t1) + Domain.Branch (p, m, domain t0, domain t1) (* [lift f s] returns the map $k\mapsto f(k)$, where $k$ ranges over a set of keys [s]. *) let rec lift f = function | Domain.Empty -> - Empty + Empty | Domain.Leaf k -> - Leaf (k, f k) + Leaf (k, f k) | Domain.Branch (p, m, t0, t1) -> - Branch(p, m, lift f t0, lift f t1) + Branch(p, m, lift f t0, lift f t1) (* [build] is a ``smart constructor''. It builds a [Branch] node with the specified arguments, but ensures that the newly created node does not have an [Empty] child. *) @@ -1021,13 +1021,13 @@ let build p m t0 t1 = match t0, t1 with | Empty, Empty -> - Empty + Empty | Empty, _ -> - t1 + t1 | _, Empty -> - t0 + t0 | _, _ -> - Branch(p, m, t0, t1) + Branch(p, m, t0, t1) (* [corestrict m d] performs a co-restriction of the map [m] to the domain [d]. That is, it returns the map $k\mapsto m(k)$, where $k$ ranges over all keys bound in [m] but \emph{not} present in [d]. Its code resembles @@ -1036,34 +1036,34 @@ let rec corestrict s t = match s, t with - | Empty, _ - | _, Domain.Empty -> - s - - | Leaf (k, _), _ -> - if Domain.mem k t then Empty else s - | _, Domain.Leaf k -> - remove k s - + | Empty, _ + | _, Domain.Empty -> + s + + | Leaf (k, _), _ -> + if Domain.mem k t then Empty else s + | _, Domain.Leaf k -> + remove k s + | Branch(p, m, s0, s1), Domain.Branch(q, n, t0, t1) -> - if (p = q) && (m = n) then + if (p = q) && (m = n) then - build p m (corestrict s0 t0) (corestrict s1 t1) + build p m (corestrict s0 t0) (corestrict s1 t1) - else if (X.shorter m n) && (match_prefix q p m) then + else if (X.shorter m n) && (match_prefix q p m) then - if (q land m) = 0 then - build p m (corestrict s0 t) s1 - else - build p m s0 (corestrict s1 t) + if (q land m) = 0 then + build p m (corestrict s0 t) s1 + else + build p m s0 (corestrict s1 t) - else if (X.shorter n m) && (match_prefix p q n) then + else if (X.shorter n m) && (match_prefix p q n) then - corestrict s (if (p land n) = 0 then t0 else t1) + corestrict s (if (p land n) = 0 then t0 else t1) - else + else - s + s end diff -Nru menhir-20151112.dfsg/src/positions.ml menhir-20160808+dfsg/src/positions.ml --- menhir-20151112.dfsg/src/positions.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/positions.ml 2016-08-08 19:19:04.000000000 +0000 @@ -3,10 +3,10 @@ open Lexing -type t = - { - start_p : Lexing.position; - end_p : Lexing.position +type t = + { + start_p : Lexing.position; + end_p : Lexing.position } type 'a located = @@ -45,13 +45,13 @@ { value = w1; position = pos }, { value = w2; position = pos } -let dummy = +let dummy = { start_p = Lexing.dummy_pos; end_p = Lexing.dummy_pos } -let unknown_pos v = +let unknown_pos v = { value = v; position = dummy @@ -61,7 +61,7 @@ let end_of_position p = p.end_p -let filename_of_position p = +let filename_of_position p = p.start_p.Lexing.pos_fname let line p = @@ -85,17 +85,17 @@ end_p = x2 } -let join_located l1 l2 f = +let join_located l1 l2 f = { value = f l1.value l2.value; position = join l1.position l2.position; } -let string_of_lex_pos p = +let string_of_lex_pos p = let c = p.pos_cnum - p.pos_bol in (string_of_int p.pos_lnum)^":"^(string_of_int c) -let string_of_pos p = +let string_of_pos p = let filename = filename_of_position p in (* [filename] is hopefully not "". *) let l = line p.start_p in @@ -107,24 +107,24 @@ | Some x -> x let cpos lexbuf = - { + { start_p = Lexing.lexeme_start_p lexbuf; - end_p = Lexing.lexeme_end_p lexbuf; + end_p = Lexing.lexeme_end_p lexbuf; } let with_cpos lexbuf v = with_pos (cpos lexbuf) v -let string_of_cpos lexbuf = +let string_of_cpos lexbuf = string_of_pos (cpos lexbuf) -let joinf f t1 t2 = +let joinf f t1 t2 = join (f t1) (f t2) let ljoinf f = List.fold_left (fun p t -> join p (f t)) dummy -let join_located_list ls f = +let join_located_list ls f = { value = f (List.map (fun l -> l.value) ls); position = ljoinf (fun x -> x.position) ls diff -Nru menhir-20151112.dfsg/src/positions.mli menhir-20160808+dfsg/src/positions.mli --- menhir-20151112.dfsg/src/positions.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/positions.mli 2016-08-08 19:19:04.000000000 +0000 @@ -44,16 +44,16 @@ (** {2 Accessors} *) -(** [column p] returns the number of characters from the +(** [column p] returns the number of characters from the beginning of the line of the Lexing.position [p]. *) val column : Lexing.position -> int (** [column p] returns the line number of to the Lexing.position [p]. *) val line : Lexing.position -> int -(** [characters p1 p2] returns the character interval +(** [characters p1 p2] returns the character interval between [p1] and [p2] assuming they are located in the same - line. + line. *) val characters : Lexing.position -> Lexing.position -> int * int @@ -61,7 +61,7 @@ val end_of_position: t -> Lexing.position -val filename_of_position: t -> string +val filename_of_position: t -> string (** {2 Position handling} *) @@ -77,9 +77,9 @@ val join_located : 'a located -> 'b located -> ('a -> 'b -> 'c) -> 'c located -val join_located_list : +val join_located_list : ('a located) list -> ('a list -> 'b list) -> ('b list) located - + (** [string_of_lex_pos p] returns a string representation for the lexing position [p]. *) @@ -98,7 +98,7 @@ (** [cpos lexbuf] returns the current position of the lexer. *) val cpos : Lexing.lexbuf -> t -(** [string_of_cpos p] returns a string representation of +(** [string_of_cpos p] returns a string representation of the lexer's current position. *) val string_of_cpos : Lexing.lexbuf -> string diff -Nru menhir-20151112.dfsg/src/pprint.ml menhir-20160808+dfsg/src/pprint.ml --- menhir-20151112.dfsg/src/pprint.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/pprint.ml 2016-08-08 19:19:04.000000000 +0000 @@ -110,7 +110,7 @@ (* A signature for document renderers. *) module type RENDERER = sig - + (* Output channels. *) type channel @@ -263,16 +263,16 @@ let rec commit channel = function | OEmpty -> - () + () | OChar (c, output) -> - commit channel output; - Output.char channel c + commit channel output; + Output.char channel c | OString (s, ofs, len, output) -> - commit channel output; - Output.substring channel s ofs len + commit channel output; + Output.substring channel s ofs len | OBlank (n, output) -> - commit channel output; - blanks channel n + commit channel output; + blanks channel n (* The renderer's abstract machine. *) @@ -306,19 +306,19 @@ and continue. *) | Empty, _ -> - shift stack state + shift stack state (* The first piece of input is a character. Emit it and continue. *) | Char c, _ -> - emit_char stack state c + emit_char stack state c (* The first piece of input is a string. Emit it and continue. *) | String (s, ofs, len), _ -> - emit_string stack state s ofs len + emit_string stack state s ofs len | Blank n, _ -> - emit_blanks stack state n + emit_blanks stack state n (* The first piece of input is a hard newline instruction. Such an instruction is valid only when flattening mode is off. *) @@ -330,37 +330,37 @@ continue. *) | HardLine, flattening -> - assert (not flattening); (* flattening mode must be off. *) - assert (stack = []); (* since flattening mode is off, the stack must be empty. *) - Output.char state.channel '\n'; - let i = state.indent1 in - blanks state.channel i; - state.column <- i; - state.indentation <- i; - shift stack state + assert (not flattening); (* flattening mode must be off. *) + assert (stack = []); (* since flattening mode is off, the stack must be empty. *) + Output.char state.channel '\n'; + let i = state.indent1 in + blanks state.channel i; + state.column <- i; + state.indentation <- i; + shift stack state (* The first piece of input is an [IfFlat] conditional instruction. *) | IfFlat (doc, _), true | IfFlat (_, doc), false -> - state.input1 <- doc; - run stack state + state.input1 <- doc; + run stack state (* The first piece of input is a concatenation operator. We take it apart and queue both documents in the input sequence. *) | Cat (doc1, doc2), _ -> - state.input1 <- doc1; - state.input <- ICons (state.indent1, state.flatten1, doc2, state.input); - run stack state + state.input1 <- doc1; + state.input <- ICons (state.indent1, state.flatten1, doc2, state.input); + run stack state (* The first piece of input is a [Nest] operator. We increase the amount of indentation to be applied to the first input document. *) | Nest (j, doc), _ -> - state.indent1 <- state.indent1 + j; - state.input1 <- doc; - run stack state + state.indent1 <- state.indent1 + j; + state.input1 <- doc; + run stack state (* The first piece of input is a [Group] operator, and flattening mode is currently off. This introduces a choice point: either we flatten @@ -374,30 +374,30 @@ modifications. This is a fork. *) | Group doc, false -> - state.input1 <- doc; - run (state :: stack) { state with flatten1 = true } + state.input1 <- doc; + run (state :: stack) { state with flatten1 = true } (* The first piece of input is a [Group] operator, and flattening mode is currently on. The operator is ignored. *) | Group doc, true -> - state.input1 <- doc; - run stack state + state.input1 <- doc; + run stack state (* The first piece of input is a [Column] operator. The current column is fed into it, so as to produce a document, with which we continue. *) | Column f, _ -> - state.input1 <- f state.column; - run stack state + state.input1 <- f state.column; + run stack state (* The first piece of input is a [Column] operator. The current indentation level is fed into it, so as to produce a document, with which we continue. *) | Nesting f, _ -> - state.input1 <- f state.indentation; - run stack state + state.input1 <- f state.indentation; + run stack state (* [shift] discards the first document in the input sequence, so that the second input document, if there is one, becomes first. The renderer stops @@ -417,41 +417,41 @@ | resumption :: stack when state.column > state.width || state.column - state.indentation > state.ribbon -> - run stack resumption + run stack resumption | _ -> - match state.input with - | INil -> + match state.input with + | INil -> - (* End of input. Commit any buffered output and stop. *) + (* End of input. Commit any buffered output and stop. *) - commit state.channel state.output + commit state.channel state.output - | ICons (indent, flatten, head, tail) -> + | ICons (indent, flatten, head, tail) -> - (* There is an input document. Move it one slot ahead and - check if we are leaving flattening mode. *) - - state.indent1 <- indent; - state.input1 <- head; - state.input <- tail; - if state.flatten1 && not flatten then begin - - (* Leaving flattening mode means success: we have flattened - a certain group, and fitted it all on a line, without - reaching a failure point. We would now like to commit our - decision to flatten this group. This is a Prolog cut. We - discard the stack of choice points, replacing it with an - empty stack, and commit all buffered output. *) - - state.flatten1 <- flatten; (* false *) - commit state.channel state.output; - state.output <- OEmpty; - run [] state - - end - else - run stack state + (* There is an input document. Move it one slot ahead and + check if we are leaving flattening mode. *) + + state.indent1 <- indent; + state.input1 <- head; + state.input <- tail; + if state.flatten1 && not flatten then begin + + (* Leaving flattening mode means success: we have flattened + a certain group, and fitted it all on a line, without + reaching a failure point. We would now like to commit our + decision to flatten this group. This is a Prolog cut. We + discard the stack of choice points, replacing it with an + empty stack, and commit all buffered output. *) + + state.flatten1 <- flatten; (* false *) + commit state.channel state.output; + state.output <- OEmpty; + run [] state + + end + else + run stack state (* [emit_char] prints a character (either to the output channel or to the output buffer), increments the current column, discards the first piece @@ -460,9 +460,9 @@ and emit_char stack state c = begin match stack with | [] -> - Output.char state.channel c + Output.char state.channel c | _ -> - state.output <- OChar (c, state.output) + state.output <- OChar (c, state.output) end; state.column <- state.column + 1; shift stack state @@ -474,9 +474,9 @@ and emit_string stack state s ofs len = begin match stack with | [] -> - Output.substring state.channel s ofs len + Output.substring state.channel s ofs len | _ -> - state.output <- OString (s, ofs, len, state.output) + state.output <- OString (s, ofs, len, state.output) end; state.column <- state.column + len; shift stack state @@ -488,9 +488,9 @@ and emit_blanks stack state n = begin match stack with | [] -> - blanks state.channel n + blanks state.channel n | _ -> - state.output <- OBlank (n, state.output) + state.output <- OBlank (n, state.output) end; state.column <- state.column + n; shift stack state @@ -523,30 +523,30 @@ let rec scan = function | Empty -> - () + () | Char c -> - Output.char channel c; - column := !column + 1 + Output.char channel c; + column := !column + 1 | String (s, ofs, len) -> - Output.substring channel s ofs len; - column := !column + len + Output.substring channel s ofs len; + column := !column + len | Blank n -> - blanks channel n; - column := !column + n + blanks channel n; + column := !column + n | HardLine -> - Output.char channel '\n'; - column := 0 + Output.char channel '\n'; + column := 0 | Cat (doc1, doc2) -> - scan doc1; - scan doc2 + scan doc1; + scan doc2 | IfFlat (doc, _) | Nest (_, doc) | Group doc -> - scan doc + scan doc | Column f -> - scan (f !column) + scan (f !column) | Nesting f -> - scan (f 0) + scan (f 0) in scan document @@ -697,9 +697,9 @@ | '\t' | '\n' | '\r' -> - blank accu (i + 1) + blank accu (i + 1) | _ -> - word break1 accu i (i + 1) + word break1 accu i (i + 1) and word prefix accu i j = (* we have skipped over at least one non-blank character *) if j = n then accu ^^ group (prefix ^^ substring s i (j - i)) @@ -708,9 +708,9 @@ | '\t' | '\n' | '\r' -> - blank (accu ^^ group (prefix ^^ substring s i (j - i))) (j + 1) + blank (accu ^^ group (prefix ^^ substring s i (j - i))) (j + 1) | _ -> - word prefix accu i (j + 1) + word prefix accu i (j + 1) in if n = 0 then empty @@ -720,9 +720,9 @@ | '\t' | '\n' | '\r' -> - blank empty 1 + blank empty 1 | _ -> - word empty empty 0 1 + word empty empty 0 1 let enclose l r x = l ^^ x ^^ r diff -Nru menhir-20151112.dfsg/src/pprint.mli menhir-20160808+dfsg/src/pprint.mli --- menhir-20151112.dfsg/src/pprint.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/pprint.mli 2016-08-08 19:19:04.000000000 +0000 @@ -142,7 +142,7 @@ (* [seq indent break empty_seq open_seq sep_seq close_seq contents] *) val seq: int -> document -> document -> document -> document -> document -> - document list -> document + document list -> document (* [seq1 open_seq sep_seq close_seq contents] Flat layout: [open_seq][contents][sep_seq]...[sep_seq][contents][close_seq] @@ -180,7 +180,7 @@ (* A signature for document renderers. *) module type RENDERER = sig - + (* Output channels. *) type channel diff -Nru menhir-20151112.dfsg/src/printer.ml menhir-20160808+dfsg/src/printer.ml --- menhir-20151112.dfsg/src/printer.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/printer.ml 2016-08-08 19:19:04.000000000 +0000 @@ -9,7 +9,7 @@ val f: out_channel - (* This controls the way we print Objective Caml stretches (types and + (* This controls the way we print OCaml stretches (types and semantic actions). We either surround them with #line directives (for better error reports if the generated code is ill - typed) or don't (for better readability). The value is either [None] -- do @@ -185,52 +185,52 @@ | ETry _ | EMatch _ -> begin - match k with - | AllButFunTryMatch - | AllButFunTryMatchSeq - | AllButLetFunTryMatch - | AllButLetFunTryMatchSeq - | OnlyAppOrAtom - | OnlyAtom -> - false - | _ -> - true + match k with + | AllButFunTryMatch + | AllButFunTryMatchSeq + | AllButLetFunTryMatch + | AllButLetFunTryMatchSeq + | OnlyAppOrAtom + | OnlyAtom -> + false + | _ -> + true end | ELet ([], e) -> member e k | ELet ((PUnit, _) :: _, _) -> begin - match k with - | AllButSeq - | AllButFunTryMatchSeq - | AllButLetFunTryMatchSeq - | AllButIfThenSeq - | OnlyAppOrAtom - | OnlyAtom -> - false - | _ -> - true + match k with + | AllButSeq + | AllButFunTryMatchSeq + | AllButLetFunTryMatchSeq + | AllButIfThenSeq + | OnlyAppOrAtom + | OnlyAtom -> + false + | _ -> + true end | ELet (_ :: _, _) -> begin - match k with - | AllButLetFunTryMatch - | AllButLetFunTryMatchSeq - | OnlyAppOrAtom - | OnlyAtom -> - false - | _ -> - true + match k with + | AllButLetFunTryMatch + | AllButLetFunTryMatchSeq + | OnlyAppOrAtom + | OnlyAtom -> + false + | _ -> + true end | EIfThen _ -> begin - match k with - | AllButIfThenSeq - | OnlyAppOrAtom - | OnlyAtom -> - false - | _ -> - true + match k with + | AllButIfThenSeq + | OnlyAppOrAtom + | OnlyAtom -> + false + | _ -> + true end | EApp (_, _ :: _) | EData (_, _ :: _) @@ -238,21 +238,21 @@ | ERepr _ | ERaise _ -> begin - match k with - | OnlyAtom -> - false - | _ -> - true + match k with + | OnlyAtom -> + false + | _ -> + true end | ERecordWrite _ | EIfThenElse _ -> begin - match k with - | OnlyAppOrAtom - | OnlyAtom -> - false - | _ -> - true + match k with + | OnlyAppOrAtom + | OnlyAtom -> + false + | _ -> + true end | EVar _ | ETextual _ @@ -281,7 +281,7 @@ fprintf f "let %s : %a = %a in%t%a" id1 typ ts1.body (* scheme ts1 *) expr e1 nl (exprlet k pes) e2 | (PVar id1, EFun (ps1, e1)) :: pes -> fprintf f "let %s%a = %a in%t%t%a" - id1 (list pat0 space) ps1 (indent 2 expr) e1 nl nl (exprlet k pes) e2 + id1 (list pat0 space) ps1 (indent 2 expr) e1 nl nl (exprlet k pes) e2 | (p1, (ELet _ as e1)) :: pes -> fprintf f "let %a =%a%tin%t%a" pat p1 (indent 2 expr) e1 nl nl (exprlet k pes) e2 | (p1, e1) :: pes -> @@ -300,85 +300,85 @@ if member e k then match e with | EComment (c, e) -> - if Settings.comment then - fprintf f "(* %s *)%t%a" c nl (exprk k) e - else - exprk k f e + if Settings.comment then + fprintf f "(* %s *)%t%a" c nl (exprk k) e + else + exprk k f e | EPatComment (s, p, e) -> - if Settings.comment then - fprintf f "(* %s%a *)%t%a" s pat p nl (exprk k) e - else - exprk k f e + if Settings.comment then + fprintf f "(* %s%a *)%t%a" s pat p nl (exprk k) e + else + exprk k f e | ELet (pes, e2) -> - exprlet k pes f e2 + exprlet k pes f e2 | ERecordWrite (e1, field, e2) -> - fprintf f "%a.%s <- %a" atom e1 field (exprk (andNotSeq k)) e2 + fprintf f "%a.%s <- %a" atom e1 field (exprk (andNotSeq k)) e2 | EMatch (_, []) -> - assert false + assert false | EMatch (e, brs) -> - fprintf f "match %a with%a" expr e (branches k) brs + fprintf f "match %a with%a" expr e (branches k) brs | ETry (_, []) -> - assert false + assert false | ETry (e, brs) -> - fprintf f "try%a%twith%a" (indent 2 expr) e nl (branches k) brs + fprintf f "try%a%twith%a" (indent 2 expr) e nl (branches k) brs | EIfThen (e1, e2) -> - fprintf f "if %a then%a" expr e1 (indent 2 (exprk (andNotSeq k))) e2 + fprintf f "if %a then%a" expr e1 (indent 2 (exprk (andNotSeq k))) e2 | EIfThenElse (e0, e1, e2) -> - fprintf f "if %a then%a%telse%a" + fprintf f "if %a then%a%telse%a" expr e0 (indent 2 (exprk AllButIfThenSeq)) e1 nl (indent 2 (exprk (andNotSeq k))) e2 | EFun (ps, e) -> - fprintf f "fun%a ->%a" (list pat0 space) ps (indent 2 (exprk k)) e + fprintf f "fun%a ->%a" (list pat0 space) ps (indent 2 (exprk k)) e | EApp (EVar op, [ e1; e2 ]) when op.[0] = '(' && op.[String.length op - 1] = ')' -> - let op = String.sub op 1 (String.length op - 2) in - fprintf f "%a %s %a" app e1 op app e2 + let op = String.sub op 1 (String.length op - 2) in + fprintf f "%a %s %a" app e1 op app e2 | EApp (e, args) -> - fprintf f "%a%a" app e (list atom space) args + fprintf f "%a%a" app e (list atom space) args | ERaise e -> - fprintf f "raise %a" atom e + fprintf f "raise %a" atom e | EMagic e -> - fprintf f "Obj.magic %a" atom e + fprintf f "Obj.magic %a" atom e | ERepr e -> - fprintf f "Obj.repr %a" atom e + fprintf f "Obj.repr %a" atom e | EData (d, []) -> - var f d + var f d | EData (d, [ arg ]) -> - fprintf f "%s %a" d atom arg + fprintf f "%s %a" d atom arg | EData ("::", [ arg1; arg2 ]) -> (* Special case for infix cons. *) fprintf f "%a :: %a" atom arg1 atom arg2 | EData (d, (_ :: _ :: _ as args)) -> - fprintf f "%s (%a)" d (seplist app comma) args + fprintf f "%s (%a)" d (seplist app comma) args | EVar v -> - var f v + var f v | ETextual action -> - stretch false f action + stretch false f action | EUnit -> - fprintf f "()" + fprintf f "()" | EIntConst k -> - if k >= 0 then - fprintf f "%d" k - else - fprintf f "(%d)" k + if k >= 0 then + fprintf f "%d" k + else + fprintf f "(%d)" k | EStringConst s -> - fprintf f "\"%s\"" (String.escaped s) + fprintf f "\"%s\"" (String.escaped s) | ETuple [] -> - assert false + assert false | ETuple [ e ] -> - atom f e + atom f e | ETuple (_ :: _ :: _ as es) -> - fprintf f "(%a)" (seplist app comma) es + fprintf f "(%a)" (seplist app comma) es | EAnnot (e, s) -> - (* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *) - fprintf f "(%a : %a)" app e typ s.body (* should be scheme s *) + (* TEMPORARY current ocaml does not support type schemes here; drop quantifiers, if any *) + fprintf f "(%a : %a)" app e typ s.body (* should be scheme s *) | ERecordAccess (e, field) -> - fprintf f "%a.%s" atom e field + fprintf f "%a.%s" atom e field | ERecord fs -> - fprintf f "{%a%t}" (indent 2 (seplist field nl)) fs nl + fprintf f "{%a%t}" (indent 2 (seplist field nl)) fs nl | EArray fs -> - fprintf f "[|%a%t|]" (indent 2 (seplist array_field nl)) fs nl + fprintf f "[|%a%t|]" (indent 2 (seplist array_field nl)) fs nl | EArrayAccess (e, i) -> - fprintf f "%a.(%a)" atom e expr i + fprintf f "%a.(%a)" atom e expr i else fprintf f "(%a)" expr e @@ -471,7 +471,7 @@ and typ0 f = function | TypTextual (Stretch.Declared ocamltype) -> (* Parentheses are necessary to avoid confusion between 1 - ary - data constructor with n arguments and n - ary data constructor. *) + data constructor with n arguments and n - ary data constructor. *) fprintf f "(%a)" (stretch true) ocamltype | TypTextual (Stretch.Inferred t) -> line := !line + LineCount.count 0 (Lexing.from_string t); diff -Nru menhir-20151112.dfsg/src/printer.mli menhir-20160808+dfsg/src/printer.mli --- menhir-20151112.dfsg/src/printer.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/printer.mli 2016-08-08 19:19:04.000000000 +0000 @@ -6,7 +6,7 @@ val f: out_channel - (* This controls the way we print Objective Caml stretches (types and + (* This controls the way we print OCaml stretches (types and semantic actions). We either surround them with #line directives (for better error reports if the generated code is ill-typed) or don't (for better readability). The value is either [None] -- do diff -Nru menhir-20151112.dfsg/src/rawPrinter.ml menhir-20160808+dfsg/src/rawPrinter.ml --- menhir-20151112.dfsg/src/rawPrinter.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/rawPrinter.ml 2016-08-08 19:19:04.000000000 +0000 @@ -210,7 +210,7 @@ (* ------------------------------------------------------------------------- *) (* Convert to a tree, then print the tree. *) -let expr e = +let expr e = print_tree X.f (expr e) end diff -Nru menhir-20151112.dfsg/src/reachability.ml menhir-20160808+dfsg/src/reachability.ml --- menhir-20151112.dfsg/src/reachability.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/reachability.ml 2016-08-08 19:19:04.000000000 +0000 @@ -25,15 +25,18 @@ else let reachable = StringSet.fold (fun symbol visited -> - visit grammar visited symbol - ) grammar.start_symbols StringSet.empty + visit grammar visited symbol + ) grammar.start_symbols StringSet.empty in StringMap.iter (fun symbol rule -> if not (StringSet.mem symbol reachable) then - Error.grammar_warning - rule.positions - "symbol %s is unreachable from any of the start symbol(s)." - symbol + Error.grammar_warning + rule.positions + "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-20151112.dfsg/src/referenceInterpreter.ml menhir-20160808+dfsg/src/referenceInterpreter.ml --- menhir-20151112.dfsg/src/referenceInterpreter.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/referenceInterpreter.ml 2016-08-08 19:19:04.000000000 +0000 @@ -13,7 +13,7 @@ let number = Lr1.number - + type token = Terminal.t @@ -41,9 +41,9 @@ let default_reduction (s : state) defred nodefred env = match Invariant.has_default_reduction s with | Some (prod, _) -> - defred env prod + defred env prod | None -> - nodefred env + nodefred env let action (s : state) (tok : terminal) value shift reduce fail env = @@ -54,27 +54,27 @@ let s' : state = SymbolMap.find (Symbol.T tok) (Lr1.transitions s) in (* There is such a transition. Return either [ShiftDiscard] or - [ShiftNoDiscard], depending on the existence of a default - reduction on [#] at [s']. *) + [ShiftNoDiscard], depending on the existence of a default + reduction on [#] at [s']. *) match Invariant.has_default_reduction s' with | Some (_, toks) when TerminalSet.mem Terminal.sharp toks -> - shift env false tok value s' + shift env false tok value s' | _ -> - shift env true tok value s' - + shift env true tok value s' + (* There is no such transition. Look for a reduction. *) with Not_found -> try - let prod = Misc.single (TerminalMap.find tok (Lr1.reductions s)) in - reduce env prod + let prod = Misc.single (TerminalMap.find tok (Lr1.reductions s)) in + reduce env prod (* There is no reduction either. Fail. *) with Not_found -> - fail env + fail env let goto (s : state) (prod : production) : state = try @@ -100,7 +100,7 @@ assert (not (Production.is_start prod)); (* Reduce. Pop a suffix of the stack, and use it to construct a - new concrete syntax tree node. *) + new concrete syntax tree node. *) let n = Production.length prod in diff -Nru menhir-20151112.dfsg/src/resizableArray.ml menhir-20160808+dfsg/src/resizableArray.ml --- menhir-20151112.dfsg/src/resizableArray.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/resizableArray.ml 2016-08-08 19:19:04.000000000 +0000 @@ -12,7 +12,7 @@ mutable size: int; (* The physical array, whose length is at least [size]. *) mutable table: 'a array - } + } let make capacity default init = (* [capacity] must be nonzero, so that doubling it actually diff -Nru menhir-20151112.dfsg/src/RowDisplacement.ml menhir-20160808+dfsg/src/RowDisplacement.ml --- menhir-20151112.dfsg/src/RowDisplacement.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/RowDisplacement.ml 2016-08-08 19:19:04.000000000 +0000 @@ -75,7 +75,7 @@ (insignificant : 'a -> bool) (dummy : 'a) (m : int) (n : int) - (t : 'a array array) + (t : 'a array array) : 'a table = (* Be defensive. *) @@ -96,13 +96,13 @@ let rec loop (j : int) (rank : int) (row : 'a row) = if j < 0 then - i, rank, row + i, rank, row else - let x = line.(j) in - if insignificant x then - loop (j - 1) rank row - else - loop (j - 1) (1 + rank) ((j, x) :: row) + let x = line.(j) in + if insignificant x then + loop (j - 1) rank row + else + loop (j - 1) (1 + rank) ((j, x) :: row) in loop (n - 1) 0 [] @@ -152,31 +152,31 @@ let rec loop = function | [] -> - true + true | (j, x) :: row -> - (* [x] is a significant element. *) + (* [x] is a significant element. *) - (* By hypothesis, [k + j] is nonnegative. If it is greater than or - equal to the current length of the data array, stop -- the row - fits. *) - - assert (k + j >= 0); - - if k + j >= d then - true - - (* We now know that [k + j] is within bounds of the data - array. Check whether it is compatible with the element [y] found - there. If it is, continue. If it isn't, stop -- the row does not - fit. *) - - else - let y = InfiniteArray.get data (k + j) in - if insignificant y || equal x y then - loop row - else - false + (* By hypothesis, [k + j] is nonnegative. If it is greater than or + equal to the current length of the data array, stop -- the row + fits. *) + + assert (k + j >= 0); + + if k + j >= d then + true + + (* We now know that [k + j] is within bounds of the data + array. Check whether it is compatible with the element [y] found + there. If it is, continue. If it isn't, stop -- the row does not + fit. *) + + else + let y = InfiniteArray.get data (k + j) in + if insignificant y || equal x y then + loop row + else + false in loop row @@ -201,23 +201,23 @@ else fit (k + 1) row in - + let fit row = match row with | [] -> - 0 (* irrelevant *) + 0 (* irrelevant *) | (j, _) :: _ -> - fit (-j) row + fit (-j) row in (* Write [row] at (compatible) offset [k]. *) let rec write k = function | [] -> - () + () | (j, x) :: row -> - InfiniteArray.set data (k + j) x; - write k row + InfiniteArray.set data (k + j) x; + write k row in (* Iterate over the sorted array of rows. Fit and write each row at diff -Nru menhir-20151112.dfsg/src/segment.mll menhir-20160808+dfsg/src/segment.mll --- menhir-20151112.dfsg/src/segment.mll 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/segment.mll 2016-08-08 19:19:04.000000000 +0000 @@ -105,6 +105,6 @@ updated based on [buf.lex_abs_pos + buf.lex_curr_pos]. *) tag, content, lexbuf ) segments - + } diff -Nru menhir-20151112.dfsg/src/sentenceLexer.mll menhir-20160808+dfsg/src/sentenceLexer.mll --- menhir-20151112.dfsg/src/sentenceLexer.mll 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/sentenceLexer.mll 2016-08-08 19:19:04.000000000 +0000 @@ -35,21 +35,21 @@ non-terminal symbol. It should be a start symbol. *) | (lowercase identchar *) as lid { try - let nt = Nonterminal.lookup lid in - if StringSet.mem lid Front.grammar.UnparameterizedSyntax.start_symbols then - NONTERMINAL (nt, lexbuf.lex_start_p, lexbuf.lex_curr_p) - else - error2 lexbuf "\"%s\" is not a start symbol." lid - with Not_found -> - error2 lexbuf "\"%s\" is not a known non-terminal symbol." lid + let nt = Nonterminal.lookup lid in + if StringSet.mem lid Front.grammar.UnparameterizedSyntax.start_symbols then + NONTERMINAL (nt, lexbuf.lex_start_p, lexbuf.lex_curr_p) + else + error2 lexbuf "\"%s\" is not a start symbol." lid + with Not_found -> + error2 lexbuf "\"%s\" is not a known non-terminal symbol." lid } (* An identifier that begins with an uppercase letter is considered a terminal symbol. *) | (uppercase identchar *) as uid { try - TERMINAL (Terminal.lookup uid, lexbuf.lex_start_p, lexbuf.lex_curr_p) - with Not_found -> - error2 lexbuf "\"%s\" is not a known terminal symbol." uid + TERMINAL (Terminal.lookup uid, lexbuf.lex_start_p, lexbuf.lex_curr_p) + with Not_found -> + error2 lexbuf "\"%s\" is not a known terminal symbol." uid } (* Whitespace is ignored. *) | whitespace diff -Nru menhir-20151112.dfsg/src/sentenceParser.mly menhir-20160808+dfsg/src/sentenceParser.mly --- menhir-20151112.dfsg/src/sentenceParser.mly 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/sentenceParser.mly 2016-08-08 19:19:04.000000000 +0000 @@ -87,7 +87,7 @@ /* An optional sentence. */ optional_sentence: | EOF - { None } + { None } | sentence { Some (strip_sentence $1) } @@ -101,8 +101,8 @@ /* A list of terminal symbols. */ terminals: -| - { [] } +| + { [] } | TERMINAL terminals { $1 :: $2 } diff -Nru menhir-20151112.dfsg/src/settings.ml menhir-20160808+dfsg/src/settings.ml --- menhir-20151112.dfsg/src/settings.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/settings.ml 2016-08-08 19:19:04.000000000 +0000 @@ -14,10 +14,17 @@ let tokentypeonly () = token_type_mode := TokenTypeOnly +let is_uppercase_ascii c = + c >= 'A' && c <= 'Z' + +let is_capitalized_ascii s = + String.length s > 0 && + is_uppercase_ascii s.[0] + let codeonly m = - if String.capitalize m <> m then begin + if not (is_capitalized_ascii m) then begin (* Not using module [Error] to avoid a circular dependency. *) - fprintf stderr "Error: %s is not a valid Objective Caml module name.\n" m; + fprintf stderr "Error: %s is not a valid OCaml module name.\n" m; exit 1 end; token_type_mode := CodeOnly m @@ -28,7 +35,7 @@ type construction_mode = | ModeCanonical (* --canonical: canonical Knuth LR(1) automaton *) | ModeInclusionOnly (* --no-pager : states are merged when there is an inclusion - relationship *) + relationship *) | ModePager (* normal mode: states are merged as per Pager's criterion *) | ModeLALR (* --lalr : states are merged as in an LALR generator, i.e. as soon as they have the same LR(0) core *) @@ -111,16 +118,16 @@ let timings = ref false -let filenames = +let filenames = ref StringSet.empty -let no_stdlib = +let no_stdlib = ref false let stdlib_path = ref Installation.libdir -let insert name = +let insert name = filenames := StringSet.add name !filenames let interpret = @@ -132,13 +139,13 @@ let interpret_error = ref false -let table = +let table = ref false let inspection = ref false -let coq = +let coq = ref false let coq_no_complete = @@ -158,6 +165,7 @@ | SuggestCompFlags | SuggestLinkFlags of string (* "cmo" or "cmx" *) | SuggestWhereIsMenhirLibSource + | SuggestUseOcamlfind let suggestion = ref SuggestNothing @@ -251,6 +259,8 @@ " Suggest link flags for ocamlopt"; "--suggest-menhirLib", Arg.Unit (fun () -> suggestion := SuggestWhereIsMenhirLibSource), " Suggest where is MenhirLib"; + "--suggest-ocamlfind", Arg.Unit (fun () -> suggestion := SuggestUseOcamlfind), + " Show whether Menhir was installed using ocamlfind"; "--table", Arg.Set table, " Use the table-based back-end"; "--timings", Arg.Set timings, " Display internal timings"; "--trace", Arg.Set trace, " Include tracing instructions in the generated code"; @@ -287,7 +297,7 @@ (* ------------------------------------------------------------------------- *) (* Menhir is able to suggest compile and link flags to be passed to the - Objective Caml compilers. If required, do so and stop. *) + OCaml compilers. If required, do so and stop. *) (* If [--table] is not passed, no flags are necessary. If [--table] is passed, then [MenhirLib] needs to be visible (at compile time) and @@ -303,17 +313,17 @@ () | SuggestCompFlags -> if !table then - if Installation.ocamlfind then - printf "-package menhirLib\n%!" - else - printf "-I %s\n%!" Installation.libdir; + if Installation.ocamlfind then + printf "-package menhirLib\n%!" + else + printf "-I %s\n%!" Installation.libdir; exit 0 | SuggestLinkFlags extension -> if !table then - if Installation.ocamlfind then - printf "-linkpkg\n%!" - else - printf "menhirLib.%s\n%!" extension; + if Installation.ocamlfind then + printf "-linkpkg\n%!" + else + printf "menhirLib.%s\n%!" extension; exit 0 | SuggestWhereIsMenhirLibSource -> if Installation.ocamlfind then @@ -322,11 +332,14 @@ else printf "%s\n%!" Installation.libdir; exit 0 + | SuggestUseOcamlfind -> + printf "%b\n" Installation.ocamlfind; + exit 0 (* ------------------------------------------------------------------------- *) (* Export the settings. *) -let stdlib_filename = +let stdlib_filename = !stdlib_path ^ "/standard.mly" let filenames = @@ -336,20 +349,20 @@ if !base = "" then match filenames with | [] -> - fprintf stderr "%s\n" usage; - exit 1 + fprintf stderr "%s\n" usage; + exit 1 | [ filename ] -> - Filename.chop_suffix filename (if !coq then ".vy" else ".mly") + Filename.chop_suffix filename (if !coq then ".vy" else ".mly") | _ -> - fprintf stderr "Error: you must specify --base when providing multiple input files.\n"; - exit 1 + fprintf stderr "Error: you must specify --base when providing multiple input files.\n"; + exit 1 else !base -let filenames = +let filenames = if !no_stdlib || !coq then filenames - else + else stdlib_filename :: filenames let token_type_mode = @@ -421,7 +434,7 @@ let interpret_error = !interpret_error -let table = +let table = !table let inspection = @@ -433,7 +446,7 @@ exit 1 end -let coq = +let coq = !coq let coq_no_complete = diff -Nru menhir-20151112.dfsg/src/settings.mli menhir-20160808+dfsg/src/settings.mli --- menhir-20151112.dfsg/src/settings.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/settings.mli 2016-08-08 19:19:04.000000000 +0000 @@ -18,9 +18,9 @@ type construction_mode = | ModeCanonical (* --canonical: canonical Knuth LR(1) automaton *) | ModeInclusionOnly (* --no-pager : states are merged when there is an inclusion - relationship, default reductions are used *) + relationship, default reductions are used *) | ModePager (* normal mode: states are merged as per Pager's criterion, - default reductions are used *) + default reductions are used *) | ModeLALR (* --lalr : states are merged as in an LALR generator, i.e. as soon as they have the same LR(0) core *) diff -Nru menhir-20151112.dfsg/src/slr.ml menhir-20160808+dfsg/src/slr.ml --- menhir-20151112.dfsg/src/slr.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/slr.ml 2016-08-08 19:19:04.000000000 +0000 @@ -75,9 +75,9 @@ Item.Map.fold (fun item toks reductions -> match Item.classify item with | Item.Reduce prod -> - addl prod toks reductions + addl prod toks reductions | Item.Shift _ -> - reductions + reductions ) s TerminalMap.empty (* The following function turns a closed LR(1) state into a set of shift @@ -136,10 +136,10 @@ if not (state_is_ok s) then begin incr count; if tell_me_everything then - Printf.fprintf - stderr - "The following SLR(1) state has a conflict:\n%s" - (Lr0.print_concrete "" s) + Printf.fprintf + stderr + "The following SLR(1) state has a conflict:\n%s" + (Lr0.print_concrete "" s) end done; diff -Nru menhir-20151112.dfsg/src/standard.mly menhir-20160808+dfsg/src/standard.mly --- menhir-20151112.dfsg/src/standard.mly 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/standard.mly 2016-08-08 19:19:04.000000000 +0000 @@ -73,7 +73,7 @@ In particular, if there is no [baz], what we get is a semantic action embedded in the middle of a rule. For instance, - + foo embedded({ action1 }) bar { action2 } is equivalent to: diff -Nru menhir-20151112.dfsg/src/StaticVersion.ml menhir-20160808+dfsg/src/StaticVersion.ml --- menhir-20151112.dfsg/src/StaticVersion.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/StaticVersion.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -let require_20151112 = () +let require_20160808 = () diff -Nru menhir-20151112.dfsg/src/StaticVersion.mli menhir-20160808+dfsg/src/StaticVersion.mli --- menhir-20151112.dfsg/src/StaticVersion.mli 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/StaticVersion.mli 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -val require_20151112 : unit +val require_20160808 : unit diff -Nru menhir-20151112.dfsg/src/stretch.mli menhir-20160808+dfsg/src/stretch.mli --- menhir-20151112.dfsg/src/stretch.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/stretch.mli 2016-08-08 19:19:04.000000000 +0000 @@ -9,15 +9,15 @@ See [Lexer.mk_stretch] and its various call sites in [Lexer]. *) type t = { - stretch_filename : string; - stretch_linenum : int; - stretch_linecount : int; - stretch_raw_content : string; - stretch_content : string; - stretch_keywords : Keyword.keyword list - } + stretch_filename : string; + stretch_linenum : int; + stretch_linecount : int; + stretch_raw_content : string; + stretch_content : string; + stretch_keywords : Keyword.keyword list + } -(* An Objective Caml type is either a stretch (if it was found in some +(* An OCaml type is either a stretch (if it was found in some source file) or a string (if it was inferred via [Infer]). *) type ocamltype = diff -Nru menhir-20151112.dfsg/src/stringMap.ml menhir-20160808+dfsg/src/stringMap.ml --- menhir-20151112.dfsg/src/stringMap.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/stringMap.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,17 +1,17 @@ include Map.Make (String) let cardinal s = - fold (fun _ _ x -> x + 1) s 0 + fold (fun _ _ x -> x + 1) s 0 let filter pred map = fold (fun key value map -> - if pred key value then - add key value map - else - map) map empty + if pred key value then + add key value map + else + map) map empty let restrict domain map = filter (fun k _ -> StringSet.mem k domain) map -let domain map = +let domain map = fold (fun key _ acu -> StringSet.add key acu) map StringSet.empty diff -Nru menhir-20151112.dfsg/src/stringMap.mli menhir-20160808+dfsg/src/stringMap.mli --- menhir-20151112.dfsg/src/stringMap.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/stringMap.mli 2016-08-08 19:19:04.000000000 +0000 @@ -1,13 +1,13 @@ include Map.S with type key = string -val cardinal : 'a t -> int +val cardinal : 'a t -> int (* [restrict s m] restricts the domain of the map [m] to (its intersection with) the set [s]. *) -val restrict: StringSet.t -> 'a t -> 'a t +val restrict: StringSet.t -> 'a t -> 'a t -(* [filter pred m] restricts the domain of the map [m] to +(* [filter pred m] restricts the domain of the map [m] to (key, value) couples that verify [pred]. *) val filter: (string -> 'a -> bool) -> 'a t -> 'a t diff -Nru menhir-20151112.dfsg/src/syntax.mli menhir-20160808+dfsg/src/syntax.mli --- menhir-20151112.dfsg/src/syntax.mli 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/syntax.mli 2016-08-08 19:19:04.000000000 +0000 @@ -1,3 +1,13 @@ +(* The type [partial_grammar] describes the abstract syntax that is produced + by the parsers (yacc-parser and fancy-parser). + + The type [grammar] describes the abstract syntax that is obtained after one + or more partial grammars are joined (see [PartialGrammar]). It differs in + that declarations are organized in a more useful way and a number of + well-formedness checks have been performed. *) + +(* ------------------------------------------------------------------------ *) + (* Terminals and nonterminal symbols are strings. Identifiers (which are used to refer to a symbol's semantic value) are strings. A file name is a string. *) @@ -6,66 +16,145 @@ string type nonterminal = - string + string type symbol = - string + string -type identifier = - string +type identifier = + string -type filename = +type filename = string +(* ------------------------------------------------------------------------ *) + (* A trailer is a source file fragment. *) type trailer = Stretch.t -(* Objective Caml semantic actions are represented as stretches. *) +(* ------------------------------------------------------------------------ *) + +(* OCaml semantic actions are represented as stretches. *) type action = Action.t -type token_associativity = - LeftAssoc +(* ------------------------------------------------------------------------ *) + +(* Information about tokens. (Only after joining.) *) + +type token_associativity = + LeftAssoc | RightAssoc | NonAssoc | UndefinedAssoc -type precedence_level = - UndefinedPrecedence +type precedence_level = + UndefinedPrecedence (* Items are incomparable when they originate in different files. A brand of type [Mark.t] is used to record an item's origin. The positions allow locating certain warnings. *) | PrecedenceLevel of Mark.t * int * Lexing.position * Lexing.position - + type token_properties = { - tk_filename : filename; - tk_ocamltype : Stretch.ocamltype option; - tk_position : Positions.t; + tk_filename : filename; + tk_ocamltype : Stretch.ocamltype option; + tk_position : Positions.t; mutable tk_associativity : token_associativity; mutable tk_precedence : precedence_level; - mutable tk_is_declared : bool; + mutable tk_is_declared : bool; } -type parameter = +(* ------------------------------------------------------------------------ *) + +(* A [%prec] annotation is optional. A production can carry at most one. + If there is one, it is a symbol name. See [ParserAux]. *) + +type branch_prec_annotation = + symbol Positions.located option + +(* ------------------------------------------------------------------------ *) + +(* A "production level" is used to solve reduce/reduce conflicts. It reflects + which production appears first in the grammar. See [ParserAux]. *) + +type branch_production_level = + | ProductionLevel of Mark.t * int + +(* ------------------------------------------------------------------------ *) + +(* 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. *) + +type parameter = | ParameterVar of symbol Positions.located | ParameterApp of symbol Positions.located * parameters + | ParameterAnonymous of parameterized_branch list Positions.located -and parameters = +and parameters = parameter list +(* ------------------------------------------------------------------------ *) + +(* A producer is a pair of identifier and a parameter. In concrete syntax, + it could be [e = expr], for instance. *) + +and producer = + identifier Positions.located * parameter + +(* ------------------------------------------------------------------------ *) + +(* A branch contains a series of producers and a semantic action. *) + +and parameterized_branch = + { + pr_branch_position : Positions.t; + pr_producers : producer list; + pr_action : action; + pr_branch_prec_annotation : branch_prec_annotation; + pr_branch_production_level : branch_production_level + } + +(* ------------------------------------------------------------------------ *) + +(* A rule has a header and several branches. *) + +type parameterized_rule = + { + pr_public_flag : bool; + pr_inline_flag : bool; + pr_nt : nonterminal; + pr_positions : Positions.t list; + pr_parameters : symbol list; + pr_branches : parameterized_branch list; + } + +(* ------------------------------------------------------------------------ *) + +(* A declaration. (Only before joining.) *) + type declaration = - (* Raw Objective Caml code. *) + (* Raw OCaml code. *) | DCode of Stretch.t - (* Raw Objective Caml functor parameter. *) + (* Raw OCaml functor parameter. *) | DParameter of Stretch.ocamltype (* really a stretch *) @@ -75,7 +164,7 @@ (* Start symbol declaration. *) - | DStart of nonterminal + | DStart of nonterminal (* Priority and associativity declaration. *) @@ -87,39 +176,40 @@ (* On-error-reduce declaration. *) - | DOnErrorReduce of parameter + | DOnErrorReduce of parameter * on_error_reduce_level -(* A [%prec] annotation is optional. A production can carry at most one. - If there is one, it is a symbol name. See [ParserAux]. *) +(* ------------------------------------------------------------------------ *) -type branch_prec_annotation = - symbol Positions.located option +(* A partial grammar. (Only before joining.) *) -(* A "production level" is used to solve reduce/reduce conflicts. It reflects - which production appears first in the grammar. See [ParserAux]. *) +type partial_grammar = + { + pg_filename : filename; + pg_trailer : trailer option; + pg_declarations : declaration Positions.located list; + pg_rules : parameterized_rule list; + } -type branch_production_level = - | ProductionLevel of Mark.t * int +(* ------------------------------------------------------------------------ *) -type producer = - identifier Positions.located * parameter +(* A grammar. (Only after joining.) *) -type parameterized_branch = - { - pr_branch_position : Positions.t; - pr_producers : producer list; - pr_action : action; - pr_branch_prec_annotation : branch_prec_annotation; - pr_branch_production_level : branch_production_level - } +(* The differences with partial grammars (above) are as follows: + 1. the file name is gone (there could be several file names, anyway). + 2. there can be several trailers, now known as postludes. + 3. declarations are organized by kind: preludes, functor %parameters, + %start symbols, %types, %tokens, %on_error_reduce. + 4. rules are stored in a map, indexed by symbol names, instead of a list. + *) -type parameterized_rule = +type grammar = { - pr_public_flag : bool; - pr_inline_flag : bool; - pr_nt : nonterminal; - pr_positions : Positions.t list; - pr_parameters : symbol list; - pr_branches : parameterized_branch list; + p_preludes : Stretch.t list; + p_postludes : trailer list; + p_parameters : Stretch.t list; + 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 * on_error_reduce_level) list; + p_rules : parameterized_rule StringMap.t; } - diff -Nru menhir-20151112.dfsg/src/tableBackend.ml menhir-20160808+dfsg/src/tableBackend.ml --- menhir-20151112.dfsg/src/tableBackend.ml 2015-11-12 20:02:03.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" @@ -220,15 +217,15 @@ ) :: ( PVar startp, if length > 0 then - EVar (Printf.sprintf "_startpos_%s_" ids.(0)) + EVar (Printf.sprintf "_startpos_%s_" ids.(0)) else endpos_of_top_stack_cell ) :: ( PVar endp, if length > 0 then - EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1)) + EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1)) else - EVar startp + EVar startp ) :: [] in @@ -274,17 +271,17 @@ (* Access the stack and current state via the environment. *) (* In fact, the current state needs be bound here only if this is - an epsilon production. Otherwise, the variable [state] will be - bound by the pattern produced by [reducecellparams] above. *) + an epsilon production. Otherwise, the variable [state] will be + bound by the pattern produced by [reducecellparams] above. *) ELet ( - [ PVar stack, ERecordAccess (EVar env, fstack) ] @ - (if Production.length prod = 0 then [ PVar state, ERecordAccess (EVar env, fcurrent) ] else []), + [ PVar stack, ERecordAccess (EVar env, fstack) ] @ + (if Production.length prod = 0 then [ PVar state, ERecordAccess (EVar env, fcurrent) ] else []), - (* Then, *) + (* Then, *) - reducebody prod + reducebody prod ) @@ -293,11 +290,11 @@ (* For productions that are never reduced, generate no code. *) (* We do this mainly because [Invariant.prodstack] does not - support productions that are never reduced. *) - + support productions that are never reduced. *) + EComment ( - "a production never reduced", - EApp (EVar "assert", [ EData ("false", []) ]) + "a production never reduced", + EApp (EVar "assert", [ EData ("false", []) ]) ) ) @@ -490,38 +487,38 @@ | Some _ -> (* [node] has a default reduction; in that case, the action - table is never looked up. *) + table is never looked up. *) hole | None -> try - let target = SymbolMap.find (Symbol.T t) (Lr1.transitions node) in + let target = SymbolMap.find (Symbol.T t) (Lr1.transitions node) in - (* [node] has a transition to [target]. If [target] has a default - reduction on [#], use [ShiftNoDiscard], otherwise [ShiftDiscard]. *) + (* [node] has a transition to [target]. If [target] has a default + reduction on [#], use [ShiftNoDiscard], otherwise [ShiftDiscard]. *) - match Invariant.has_default_reduction target with - | Some (_, toks) when TerminalSet.mem Terminal.sharp toks -> - assert (TerminalSet.cardinal toks = 1); - encode_ShiftNoDiscard target - | _ -> - encode_ShiftDiscard target + match Invariant.has_default_reduction target with + | Some (_, toks) when TerminalSet.mem Terminal.sharp toks -> + assert (TerminalSet.cardinal toks = 1); + encode_ShiftNoDiscard target + | _ -> + encode_ShiftDiscard target with Not_found -> - try + try - (* [node] has a reduction. *) + (* [node] has a reduction. *) - let prod = Misc.single (TerminalMap.find t (Lr1.reductions node)) in - encode_Reduce prod + let prod = Misc.single (TerminalMap.find t (Lr1.reductions node)) in + encode_Reduce prod - with Not_found -> + with Not_found -> - (* [node] has no action. *) + (* [node] has no action. *) - encode_Fail + encode_Fail (* In the error bitmap and in the action table, the row that corresponds to the [#] pseudo-terminal is never accessed. Thus, we do not create this row. This @@ -566,9 +563,9 @@ "action", marshal2 "action" Lr1.n (Terminal.n - 1) ( Lr1.map (fun node -> - Terminal.mapx (fun t -> - action node t - ) + Terminal.mapx (fun t -> + action node t + ) ) ) ) @@ -578,9 +575,9 @@ "goto", marshal2 "goto" Lr1.n Nonterminal.n ( Lr1.map (fun node -> - Nonterminal.map (fun nt -> - goto node nt - ) + Nonterminal.map (fun nt -> + goto node nt + ) ) ) ) @@ -602,7 +599,7 @@ "default_reduction", marshal1_list ( Lr1.map (fun node -> - default_reduction node + default_reduction node ) ) ) @@ -612,7 +609,7 @@ "lhs", marshal1 ( Production.amap (fun prod -> - Nonterminal.n2i (Production.nt prod) + Nonterminal.n2i (Production.nt prod) ) ) ) @@ -644,10 +641,10 @@ "trace", if Settings.trace then EData ("Some", [ - ETuple [ - EArray (Terminal.map (stringwrap Terminal.print)); - EArray (Production.map (stringwrap reduce_or_accept)); - ] + ETuple [ + EArray (Terminal.map (stringwrap Terminal.print)); + EArray (Production.map (stringwrap reduce_or_accept)); + ] ]) else EData ("None", []) @@ -672,11 +669,11 @@ true (fun tok -> ERepr ( - match Terminal.ocamltype tok with - | None -> - EUnit - | Some _ -> - EVar semv + match Terminal.ocamltype tok with + | None -> + EUnit + | Some _ -> + EVar semv ) ) @@ -973,7 +970,7 @@ Front.grammar let program = - + [ SIFunctor (grammar.parameters, (* Make a reference to [MenhirLib.StaticVersion.require_XXXXXXXX], where @@ -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-20151112.dfsg/src/TableFormat.ml menhir-20160808+dfsg/src/TableFormat.ml --- menhir-20151112.dfsg/src/TableFormat.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/TableFormat.ml 2016-08-08 19:19:04.000000000 +0000 @@ -18,7 +18,7 @@ module type TABLES = sig (* This is the parser's type of tokens. *) - + type token (* This maps a token to its internal (generation-time) integer code. *) @@ -119,7 +119,7 @@ actions. The calling convention for semantic actions is described in [EngineTypes]. This table contains ONLY NON-START PRODUCTIONS, so the indexing is off by [start]. Be careful. *) - + val semantic_action: ((int, Obj.t, token) EngineTypes.env -> (int, Obj.t) EngineTypes.stack) array diff -Nru menhir-20151112.dfsg/src/TableInterpreter.ml menhir-20160808+dfsg/src/TableInterpreter.ml --- menhir-20151112.dfsg/src/TableInterpreter.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/TableInterpreter.ml 2016-08-08 19:19:04.000000000 +0000 @@ -29,22 +29,22 @@ type semantic_value = Obj.t - + let token2terminal = T.token2terminal - + let token2value = T.token2value - + let error_terminal = T.error_terminal let error_value = Obj.repr () - + type production = int - + let default_reduction state defred nodefred env = let code = PackedIntArray.get T.default_reduction state in if code = 0 then @@ -54,7 +54,7 @@ let is_start prod = prod < T.start - + (* This auxiliary function helps access a compressed, two-dimensional matrix, like the action and goto tables. *) @@ -71,69 +71,69 @@ let action state terminal value shift reduce fail env = match PackedIntArray.unflatten1 T.error state terminal with | 1 -> - let action = unmarshal2 T.action state terminal in - let opcode = action land 0b11 - and param = action lsr 2 in - if opcode >= 0b10 then - (* 0b10 : shift/discard *) - (* 0b11 : shift/nodiscard *) - let please_discard = (opcode = 0b10) in - shift env please_discard terminal value param - else - (* 0b01 : reduce *) - (* 0b00 : cannot happen *) - reduce env param + let action = unmarshal2 T.action state terminal in + let opcode = action land 0b11 + and param = action lsr 2 in + if opcode >= 0b10 then + (* 0b10 : shift/discard *) + (* 0b11 : shift/nodiscard *) + let please_discard = (opcode = 0b10) in + shift env please_discard terminal value param + else + (* 0b01 : reduce *) + (* 0b00 : cannot happen *) + reduce env param | c -> - assert (c = 0); - fail env - + assert (c = 0); + fail env + let goto state prod = let code = unmarshal2 T.goto state (PackedIntArray.get T.lhs prod) in (* code = 1 + state *) code - 1 exception Error = - T.Error + T.Error type semantic_action = (state, semantic_value, token) EngineTypes.env -> (state, semantic_value) EngineTypes.stack - + let semantic_action prod = (* Indexing into the array [T.semantic_action] is off by [T.start], because the start productions do not have entries in this array. *) T.semantic_action.(prod - T.start) - + (* If [T.trace] is [None], then the logging functions do nothing. *) let log = match T.trace with Some _ -> true | None -> false module Log = struct - + open Printf - + let state state = match T.trace with | Some _ -> fprintf stderr "State %d:\n%!" state | None -> - () - + () + let shift terminal state = match T.trace with | Some (terminals, _) -> fprintf stderr "Shifting (%s) to state %d\n%!" terminals.(terminal) state | None -> - () - + () + let reduce_or_accept prod = match T.trace with | Some (_, productions) -> fprintf stderr "%s\n%!" productions.(prod) | None -> - () - + () + let lookahead_token token startp endp = match T.trace with | Some (terminals, _) -> @@ -142,30 +142,30 @@ startp.Lexing.pos_cnum endp.Lexing.pos_cnum | None -> - () - + () + let initiating_error_handling () = match T.trace with | Some _ -> fprintf stderr "Initiating error handling\n%!" | None -> - () - + () + let resuming_error_handling () = match T.trace with | Some _ -> fprintf stderr "Resuming error handling\n%!" | None -> - () - + () + let handling_error state = match T.trace with | Some _ -> fprintf stderr "Handling error in state %d\n%!" state | None -> - () - + () + end - + end) diff -Nru menhir-20151112.dfsg/src/TableInterpreter.mli menhir-20160808+dfsg/src/TableInterpreter.mli --- menhir-20151112.dfsg/src/TableInterpreter.mli 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/TableInterpreter.mli 2016-08-08 19:19:04.000000000 +0000 @@ -26,6 +26,6 @@ : EngineTypes.ENGINE with type state = int and type token = T.token - and type semantic_value = Obj.t + and type semantic_value = Obj.t and type production = int diff -Nru menhir-20151112.dfsg/src/_tags menhir-20160808+dfsg/src/_tags --- menhir-20151112.dfsg/src/_tags 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/_tags 2016-08-08 19:19:04.000000000 +0000 @@ -13,3 +13,9 @@ # Turn off assertions in some modules, where they are useful when debugging, but costly. : noassert +# Declare that our temporary build directories should not be traversed. +# This is required by ocamlbuild 4.03; it will otherwise complain that +# these build directories violate its hygiene rules. +<_build>: -traverse +<_stage*>: -traverse + diff -Nru menhir-20151112.dfsg/src/tarjan.ml menhir-20160808+dfsg/src/tarjan.ml --- menhir-20151112.dfsg/src/tarjan.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/tarjan.ml 2016-08-08 19:19:04.000000000 +0000 @@ -30,33 +30,33 @@ type data = { (* Each node carries a flag which tells whether it appears - within the SCC stack (which is defined below). *) + within the SCC stack (which is defined below). *) mutable stacked: bool; (* Each node carries a number. Numbers represent the order in - which nodes were discovered. *) + which nodes were discovered. *) mutable number: int; (* Each node [x] records the lowest number associated to a node - already detected within [x]'s SCC. *) + already detected within [x]'s SCC. *) mutable low: int; (* Each node carries a pointer to a representative element of - its SCC. This field is used by the algorithm to store its - results. *) + its SCC. This field is used by the algorithm to store its + results. *) mutable representative: G.node; (* Each representative node carries a list of the nodes in - its SCC. This field is used by the algorithm to store its - results. *) + its SCC. This field is used by the algorithm to store its + results. *) mutable scc: G.node list - } + } (* Define a mapping from external nodes to internal ones. Here, we simply use each node's index as an entry into a global array. *) @@ -73,10 +73,10 @@ G.iter (fun x -> table.(G.index x) <- Some { - stacked = false; - number = 0; - low = 0; - representative = x; + stacked = false; + number = 0; + low = 0; + representative = x; scc = [] } ); @@ -86,10 +86,10 @@ function x -> match table.(G.index x) with - | Some dx -> - dx - | None -> - assert false (* Indices do not cover the range $0\ldots n$, as expected. *) + | Some dx -> + dx + | None -> + assert false (* Indices do not cover the range $0\ldots n$, as expected. *) (* Create an empty stack, used to record all nodes which belong to the current SCC. *) @@ -123,70 +123,70 @@ if droot.number = 0 then begin (* This node hasn't been visited yet. Start a depth-first walk - from it. *) + from it. *) mark droot; droot.stacked <- true; Stack.push droot scc_stack; let rec walk x = - let dx = table x in + let dx = table x in - G.successors (fun y -> - let dy = table y in + G.successors (fun y -> + let dy = table y in - if dy.number = 0 then begin + if dy.number = 0 then begin - (* $y$ hasn't been visited yet, so $(x,y)$ is a regular - edge, part of the search forest. *) + (* $y$ hasn't been visited yet, so $(x,y)$ is a regular + edge, part of the search forest. *) - mark dy; - dy.stacked <- true; - Stack.push dy scc_stack; + mark dy; + dy.stacked <- true; + Stack.push dy scc_stack; - (* Continue walking, depth-first. *) + (* Continue walking, depth-first. *) - walk y; - if dy.low < dx.low then - dx.low <- dy.low + walk y; + if dy.low < dx.low then + dx.low <- dy.low - end - else if (dy.low < dx.low) && dy.stacked then begin + end + else if (dy.low < dx.low) && dy.stacked then begin - (* The first condition above indicates that $y$ has been - visited before $x$, so $(x, y)$ is a backwards or - transverse edge. The second condition indicates that - $y$ is inside the same SCC as $x$; indeed, if it - belongs to another SCC, then the latter has already - been identified and moved out of [scc_stack]. *) + (* The first condition above indicates that $y$ has been + visited before $x$, so $(x, y)$ is a backwards or + transverse edge. The second condition indicates that + $y$ is inside the same SCC as $x$; indeed, if it + belongs to another SCC, then the latter has already + been identified and moved out of [scc_stack]. *) - if dy.number < dx.low then - dx.low <- dy.number + if dy.number < dx.low then + dx.low <- dy.number - end + end - ) x; + ) x; - (* We are done visiting $x$'s neighbors. *) + (* We are done visiting $x$'s neighbors. *) - if dx.low = dx.number then begin + if dx.low = dx.number then begin - (* $x$ is the entry point of a SCC. The whole SCC is now - available; move it out of the stack. We pop elements out - of the SCC stack until $x$ itself is found. *) + (* $x$ is the entry point of a SCC. The whole SCC is now + available; move it out of the stack. We pop elements out + of the SCC stack until $x$ itself is found. *) - let rec loop () = - let element = Stack.pop scc_stack in - element.stacked <- false; + let rec loop () = + let element = Stack.pop scc_stack in + element.stacked <- false; dx.scc <- element.representative :: dx.scc; - element.representative <- x; - if element != dx then - loop() in + element.representative <- x; + if element != dx then + loop() in - loop(); - representatives := x :: !representatives + loop(); + representatives := x :: !representatives - end in + end in walk root diff -Nru menhir-20151112.dfsg/src/tokenType.ml menhir-20160808+dfsg/src/tokenType.ml --- menhir-20151112.dfsg/src/tokenType.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/tokenType.ml 2016-08-08 19:19:04.000000000 +0000 @@ -142,8 +142,8 @@ | Settings.TokenTypeOnly -> (* Create both an .mli file and an .ml file. This is made - necessary by the fact that the two can be different - when there are functor parameters. *) + necessary by the fact that the two can be different + when there are functor parameters. *) let i = tokentypedef grammar @ @@ -152,20 +152,20 @@ ) in - let module P = - Printer.Make (struct - let f = open_out (Settings.base ^ ".mli") - let locate_stretches = None - end) + let module P = + Printer.Make (struct + let f = open_out (Settings.base ^ ".mli") + let locate_stretches = None + end) in P.interface [ IIFunctor (grammar.parameters, i) ]; - let module P = - Printer.Make (struct - let f = open_out (Settings.base ^ ".ml") - let locate_stretches = None - end) + let module P = + Printer.Make (struct + let f = open_out (Settings.base ^ ".ml") + let locate_stretches = None + end) in P.program [ SIFunctor (grammar.parameters, diff -Nru menhir-20151112.dfsg/src/traverse.ml menhir-20160808+dfsg/src/traverse.ml --- menhir-20151112.dfsg/src/traverse.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/traverse.ml 2016-08-08 19:19:04.000000000 +0000 @@ -31,17 +31,17 @@ method pat env = function | PWildcard | PUnit -> - env + env | PVar id -> - self#pvar env id + self#pvar env id | PTuple ps | POr ps | PData (_, ps) -> - self#pats env ps + self#pats env ps | PAnnot (p, _) -> self#pat env p | PRecord fps -> - self#fpats env fps + self#fpats env fps method pats env ps = List.fold_left self#pat env ps @@ -62,7 +62,7 @@ class virtual ['env] map = object (self) inherit ['env] env - + method expr (env : 'env) e = try match e with @@ -113,22 +113,22 @@ | EPatComment (s, p, e) -> self#epatcomment env s p e | EArray es -> - self#earray env es + self#earray env es | EArrayAccess (e, i) -> - self#earrayaccess env e i + self#earrayaccess env e i with NoChange -> e - + method evar _env _x = raise NoChange - + method efun env ps e = let e' = self#expr (self#pats env ps) e in if e == e' then raise NoChange else EFun (ps, e') - + method eapp env e es = let e' = self#expr env e and es' = self#exprs env es in @@ -136,7 +136,7 @@ raise NoChange else EApp (e', es') - + method elet env bs e = let env, bs' = self#bindings env bs in let e' = self#expr env e in @@ -144,7 +144,7 @@ raise NoChange else ELet (bs', e') - + method ematch env e bs = let e' = self#expr env e and bs' = self#branches env bs in @@ -152,7 +152,7 @@ raise NoChange else EMatch (e', bs') - + method eifthen env e e1 = let e' = self#expr env e and e1' = self#expr env e1 in @@ -160,7 +160,7 @@ raise NoChange else EIfThen (e', e1') - + method eifthenelse env e e1 e2 = let e' = self#expr env e and e1' = self#expr env e1 @@ -169,14 +169,14 @@ raise NoChange else EIfThenElse (e', e1', e2') - + method eraise env e = let e' = self#expr env e in if e == e' then raise NoChange else ERaise e' - + method etry env e bs = let e' = self#expr env e and bs' = self#branches env bs in @@ -184,65 +184,65 @@ raise NoChange else ETry (e', bs') - + method eunit _env = raise NoChange - + method eintconst _env _k = raise NoChange - + method estringconst _env _s = raise NoChange - + method edata env d es = let es' = self#exprs env es in if es == es' then raise NoChange else EData (d, es') - + method etuple env es = let es' = self#exprs env es in if es == es' then raise NoChange else ETuple es' - + method eannot env e t = let e' = self#expr env e in if e == e' then raise NoChange else EAnnot (e', t) - + method emagic env e = let e' = self#expr env e in if e == e' then raise NoChange else EMagic e' - + method erepr env e = let e' = self#expr env e in if e == e' then raise NoChange else ERepr e' - + method erecord env fs = let fs' = self#fields env fs in if fs == fs' then raise NoChange else ERecord fs' - + method erecordaccess env e f = let e' = self#expr env e in if e == e' then raise NoChange else ERecordAccess (e', f) - + method erecordwrite env e f e1 = let e' = self#expr env e and e1' = self#expr env e1 in @@ -250,54 +250,54 @@ raise NoChange else ERecordWrite (e', f, e1') - + method earray env es = let es' = self#exprs env es in if es == es' then raise NoChange else EArray es' - + method earrayaccess env e i = let e' = self#expr env e in if e == e' then raise NoChange else EArrayAccess (e', i) - + method etextual _env _action = raise NoChange - + method ecomment env s e = let e' = self#expr env e in if e == e' then raise NoChange else EComment (s, e') - + method epatcomment env s p e = let e' = self#expr env e in if e == e' then raise NoChange else EPatComment (s, p, e') - + method exprs env es = Misc.smap (self#expr env) es - + method fields env fs = Misc.smap (self#field env) fs - + method field env ((f, e) as field) = let e' = self#expr env e in if e == e' then field else (f, e') - + method branches env bs = Misc.smap (self#branch env) bs - + method branch env b = let e = b.branchbody in let e' = self#expr (self#pat env b.branchpat) e in @@ -308,7 +308,7 @@ (* The method [binding] produces a pair of an updated environment and a transformed binding. *) - + method binding env ((p, e) as b) = let e' = self#expr env e in self#pat env p, @@ -316,12 +316,12 @@ b else (p, e') - + (* For nested non-recursive bindings, the environment produced by each binding is used to traverse the following bindings. The method [binding] produces a pair of an updated environment and a transformed list of bindings. *) - + method bindings env bs = Misc.smapa self#binding env bs @@ -332,7 +332,7 @@ def else { def with valval = e' } - + method valdefs env defs = Misc.smap (self#valdef env) defs @@ -343,7 +343,7 @@ class virtual ['env, 'a] fold = object (self) inherit ['env] env - + method expr (env : 'env) (accu : 'a) e = match e with | EVar x -> @@ -393,144 +393,144 @@ | EPatComment (s, p, e) -> self#epatcomment env accu s p e | EArray es -> - self#earray env accu es + self#earray env accu es | EArrayAccess (e, i) -> - self#earrayaccess env accu e i + self#earrayaccess env accu e i method evar (_env : 'env) (accu : 'a) _x = accu - + method efun (env : 'env) (accu : 'a) ps e = let accu = self#expr (self#pats env ps) accu e in accu - + method eapp (env : 'env) (accu : 'a) e es = let accu = self#expr env accu e in let accu = self#exprs env accu es in accu - + method elet (env : 'env) (accu : 'a) bs e = let env, accu = self#bindings env accu bs in let accu = self#expr env accu e in accu - + method ematch (env : 'env) (accu : 'a) e bs = let accu = self#expr env accu e in let accu = self#branches env accu bs in accu - + method eifthen (env : 'env) (accu : 'a) e e1 = let accu = self#expr env accu e in let accu = self#expr env accu e1 in accu - + method eifthenelse (env : 'env) (accu : 'a) e e1 e2 = let accu = self#expr env accu e in let accu = self#expr env accu e1 in let accu = self#expr env accu e2 in accu - + method eraise (env : 'env) (accu : 'a) e = let accu = self#expr env accu e in accu - + method etry (env : 'env) (accu : 'a) e bs = let accu = self#expr env accu e in let accu = self#branches env accu bs in accu - + method eunit (_env : 'env) (accu : 'a) = accu - + method eintconst (_env : 'env) (accu : 'a) _k = accu - + method estringconst (_env : 'env) (accu : 'a) _s = accu - + method edata (env : 'env) (accu : 'a) _d es = let accu = self#exprs env accu es in accu - + method etuple (env : 'env) (accu : 'a) es = let accu = self#exprs env accu es in accu - + method eannot (env : 'env) (accu : 'a) e _t = let accu = self#expr env accu e in accu - + method emagic (env : 'env) (accu : 'a) e = let accu = self#expr env accu e in accu - + method erepr (env : 'env) (accu : 'a) e = let accu = self#expr env accu e in accu - + method erecord (env : 'env) (accu : 'a) fs = let accu = self#fields env accu fs in accu - + method erecordaccess (env : 'env) (accu : 'a) e _f = let accu = self#expr env accu e in accu - + method erecordwrite (env : 'env) (accu : 'a) e _f e1 = let accu = self#expr env accu e in let accu = self#expr env accu e1 in accu - + method earray (env : 'env) (accu : 'a) es = let accu = self#exprs env accu es in accu - + method earrayaccess (env : 'env) (accu : 'a) e _i = let accu = self#expr env accu e in accu - + method etextual (_env : 'env) (accu : 'a) _action = accu - + method ecomment (env : 'env) (accu : 'a) _s e = let accu = self#expr env accu e in accu - + method epatcomment (env : 'env) (accu : 'a) _s _p e = let accu = self#expr env accu e in accu - + method exprs (env : 'env) (accu : 'a) es = List.fold_left (self#expr env) accu es - + method fields (env : 'env) (accu : 'a) fs = List.fold_left (self#field env) accu fs - + method field (env : 'env) (accu : 'a) (_f, e) = let accu = self#expr env accu e in accu - + method branches (env : 'env) (accu : 'a) bs = List.fold_left (self#branch env) accu bs - + method branch (env : 'env) (accu : 'a) b = let accu = self#expr (self#pat env b.branchpat) accu b.branchbody in accu - + method binding ((env, accu) : 'env * 'a) (p, e) = let accu = self#expr env accu e in self#pat env p, accu - + method bindings (env : 'env) (accu : 'a) bs = List.fold_left self#binding (env, accu) bs - + method valdef (env : 'env) (accu : 'a) def = let accu = self#expr env accu def.valval in accu - + method valdefs (env : 'env) (accu : 'a) defs = List.fold_left (self#valdef env) accu defs - + end diff -Nru menhir-20151112.dfsg/src/unionFind.ml menhir-20160808+dfsg/src/unionFind.ml --- menhir-20151112.dfsg/src/unionFind.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/unionFind.ml 2016-08-08 19:19:04.000000000 +0000 @@ -19,7 +19,7 @@ of elements in the class) and of the class's descriptor. *) type 'a point = { mutable link: 'a link - } + } and 'a link = | Info of 'a info @@ -28,13 +28,13 @@ and 'a info = { mutable weight: int; mutable descriptor: 'a - } + } (** [fresh desc] creates a fresh point and returns it. It forms an equivalence class of its own, whose descriptor is [desc]. *) let fresh desc = { link = Info { weight = 1; descriptor = desc } -} +} (** [repr point] returns the representative element of [point]'s equivalence class. It is found by starting at [point] and following @@ -46,13 +46,13 @@ let point'' = repr point' in if point'' != point' then - (* [point''] is [point']'s representative element. Because we - just invoked [repr point'], [point'.link] must be [Link - point'']. We write this value into [point.link], thus - performing path compression. Note that this function never - performs memory allocation. *) + (* [point''] is [point']'s representative element. Because we + just invoked [repr point'], [point'.link] must be [Link + point'']. We write this value into [point.link], thus + performing path compression. Note that this function never + performs memory allocation. *) - point.link <- point'.link; + point.link <- point'.link; point'' | Info _ -> point @@ -72,7 +72,7 @@ | Link { link = Link _ } -> find (repr point) -let rec change point v = +let rec change point v = match point.link with | Info info | Link { link = Info info } -> @@ -101,13 +101,13 @@ let weight1 = info1.weight and weight2 = info2.weight in if weight1 >= weight2 then begin - point2.link <- Link point1; - info1.weight <- weight1 + weight2; - info1.descriptor <- info2.descriptor + point2.link <- Link point1; + info1.weight <- weight1 + weight2; + info1.descriptor <- info2.descriptor end else begin - point1.link <- Link point2; - info2.weight <- weight1 + weight2 + point1.link <- Link point2; + info2.weight <- weight1 + weight2 end | _, _ -> assert false (* [repr] guarantees that [link] matches [Info _]. *) diff -Nru menhir-20151112.dfsg/src/unparameterizedPrinter.ml menhir-20160808+dfsg/src/unparameterizedPrinter.ml --- menhir-20151112.dfsg/src/unparameterizedPrinter.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/unparameterizedPrinter.ml 2016-08-08 19:19:04.000000000 +0000 @@ -9,25 +9,25 @@ Printf.fprintf f "%%{%s%%}\n" prelude.stretch_raw_content ) g.preludes -let print_start_symbols b g = +let print_start_symbols b g = StringSet.iter (fun symbol -> Printf.fprintf b "%%start %s\n" (Misc.normalize symbol) ) g.start_symbols - + let rec insert_in_partitions item m = function - | [] -> + | [] -> [ (m, [ item ]) ] - - | (m', items) :: partitions when Mark.same m m' -> + + | (m', items) :: partitions when Mark.same m m' -> (m', item :: items) :: partitions - + | t :: partitions -> t :: (insert_in_partitions item m partitions) - + let insert (undefined, partitions) = function | (item, UndefinedPrecedence) -> ((item, 0) :: undefined, partitions) - + | (item, PrecedenceLevel (m, v, _, _)) -> (undefined, insert_in_partitions (item, v) m partitions) @@ -35,9 +35,9 @@ Printf.sprintf " <%s>" ( match ocamltype with | Declared stretch -> - stretch.stretch_raw_content + stretch.stretch_raw_content | Inferred t -> - t + t ) let print_assoc = function @@ -50,15 +50,15 @@ | UndefinedAssoc -> "" -let print_tokens mode b g = +let print_tokens mode b g = (* Sort tokens wrt precedence. *) - let undefined, partition_tokens = + let undefined, partition_tokens = StringMap.fold (fun token prop acu -> insert acu (token, prop.tk_precedence) ) g.tokens ([], []) in let ordered_tokens = - List.fold_left (fun acu (_, ms) -> + List.fold_left (fun acu (_, ms) -> acu @ List.sort (fun (_, v) (_, v') -> compare v v') ms ) undefined partition_tokens in @@ -66,53 +66,53 @@ let prop = StringMap.find token g.tokens in if prop.tk_is_declared then Printf.fprintf b "%%token%s %s\n" - begin match mode with - | PrintNormal - | PrintUnitActions -> - Misc.o2s prop.tk_ocamltype print_ocamltype - | PrintUnitActionsUnitTokens -> - "" (* omitted ocamltype after %token means *) - end - token + begin match mode with + | PrintNormal + | PrintUnitActions -> + Misc.o2s prop.tk_ocamltype print_ocamltype + | PrintUnitActionsUnitTokens -> + "" (* omitted ocamltype after %token means *) + end + token ) ordered_tokens; - ignore (List.fold_left - (fun last_prop (token, v) -> - let prop = StringMap.find token g.tokens in - match last_prop with - - | None -> - if prop.tk_associativity = UndefinedAssoc then - None - else ( - Printf.fprintf b "%s %s " - (print_assoc prop.tk_associativity) token; - Some v) - - | Some v' when v <> v' -> - if prop.tk_associativity = UndefinedAssoc then - None - else ( - Printf.fprintf b "\n%s %s " - (print_assoc prop.tk_associativity) token; - Some v) - - | Some _ -> - Printf.fprintf b "%s " token; - last_prop - - ) None ordered_tokens); + ignore (List.fold_left + (fun last_prop (token, v) -> + let prop = StringMap.find token g.tokens in + match last_prop with + + | None -> + if prop.tk_associativity = UndefinedAssoc then + None + else ( + Printf.fprintf b "%s %s " + (print_assoc prop.tk_associativity) token; + Some v) + + | Some v' when v <> v' -> + if prop.tk_associativity = UndefinedAssoc then + None + else ( + Printf.fprintf b "\n%s %s " + (print_assoc prop.tk_associativity) token; + Some v) + + | Some _ -> + Printf.fprintf b "%s " token; + last_prop + + ) None ordered_tokens); Printf.fprintf b "\n" -let print_types mode b g = +let print_types mode b g = StringMap.iter (fun symbol ty -> - Printf.fprintf b "%%type%s %s\n" + Printf.fprintf b "%%type%s %s\n" begin match mode with | PrintNormal -> - print_ocamltype ty + print_ocamltype ty | PrintUnitActions | PrintUnitActionsUnitTokens -> - " " + " " end (Misc.normalize symbol) ) g.types @@ -128,7 +128,7 @@ let string_of_producer mode (symbol, ido) = binding mode ido ^ (Misc.normalize symbol) -let print_branch mode f branch = +let print_branch mode f branch = Printf.fprintf f "%s%s\n {" (String.concat " " (List.map (string_of_producer mode) branch.producers)) (Misc.o2s branch.branch_prec_annotation (fun x -> " %prec "^x.value)); @@ -147,37 +147,37 @@ (* Because the resolution of reduce/reduce conflicts is implicitly dictated by the order in which productions appear in the grammar, the printer should be careful to preserve this order. *) -let branches_order r r' = - let branch_order b b' = +let branches_order r r' = + let branch_order b b' = match b.branch_production_level, b'.branch_production_level with | ProductionLevel (m, l), ProductionLevel (m', l') -> - if Mark.same m m' then - if l < l' then - -1 - else if l > l' then - 1 - else - 0 - else 0 + if Mark.same m m' then + if l < l' then + -1 + else if l > l' then + 1 + else + 0 + else 0 in - let rec lexical_order bs bs' = + let rec lexical_order bs bs' = match bs, bs' with | [], [] -> - 0 + 0 | [], _ -> - -1 + -1 | _, [] -> - 1 + 1 | b :: bs, b' :: bs' -> - match branch_order b b' with - | 0 -> - lexical_order bs bs' - | x -> - x + match branch_order b b' with + | 0 -> + lexical_order bs bs' + | x -> + x in lexical_order r.branches r'.branches -let print_rules mode b g = +let print_rules mode b g = let rules_as_list = StringMap.fold (fun nt r acu -> (nt, r) :: acu) g.rules [] in @@ -186,8 +186,12 @@ in List.iter (fun (nt, r) -> Printf.fprintf b "\n%s:\n" (Misc.normalize nt); - List.iter (fun br -> - Printf.fprintf b "| "; + let first = ref true in + List.iter (fun br -> + (* Menhir accepts a leading "|", but bison does not. Let's not print it. *) + let sep = if !first then " " else "| " in + first := false; + Printf.fprintf b "%s" sep; print_branch mode b br ) r.branches ) ordered_rules @@ -213,4 +217,3 @@ | PrintUnitActionsUnitTokens -> () end - diff -Nru menhir-20151112.dfsg/src/unparameterizedSyntax.ml menhir-20160808+dfsg/src/unparameterizedSyntax.ml --- menhir-20151112.dfsg/src/unparameterizedSyntax.ml 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/unparameterizedSyntax.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1,6 +1,6 @@ -(* A parameterized branch may instantiate parameterized non terminals. - If the parameterized branch contributes to the definition of a - parameterized terminal, then the instantiation of parameterized +(* A parameterized branch may instantiate parameterized non terminals. + If the parameterized branch contributes to the definition of a + parameterized terminal, then the instantiation of parameterized non terminals that are defined simultaneously must only be done with formal parameters. Furthermore, all the parameterized non terminals that are in a common @@ -18,31 +18,31 @@ type branch = { branch_position : Positions.t; - producers : (symbol * identifier) list; (* TEMPORARY convention renversée + producers : (symbol * identifier) list; (* TEMPORARY convention renversée par rapport à syntax.mli; faire un type record au lieu d'une paire? *) - action : action; - branch_prec_annotation : branch_prec_annotation; + action : action; + branch_prec_annotation : branch_prec_annotation; branch_production_level : branch_production_level } -type rule = +type rule = { - branches : branch list; + branches : branch list; positions : Positions.t list; (* This flag is not relevant after the NonTerminalInlining.inline pass. *) inline_flag : bool; } -type grammar = +type grammar = { - preludes : Stretch.t list; - postludes : Syntax.trailer list; + preludes : Stretch.t list; + postludes : Syntax.trailer list; 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; + on_error_reduce : on_error_reduce_level StringMap.t; + tokens : Syntax.token_properties StringMap.t; + rules : rule StringMap.t; } (* [tokens grammar] is a list of all (real) tokens in the grammar @@ -87,4 +87,3 @@ with Not_found -> (* Every start symbol should have a type. *) assert false - diff -Nru menhir-20151112.dfsg/src/version.ml menhir-20160808+dfsg/src/version.ml --- menhir-20151112.dfsg/src/version.ml 2015-11-12 20:02:04.000000000 +0000 +++ menhir-20160808+dfsg/src/version.ml 2016-08-08 19:19:04.000000000 +0000 @@ -1 +1 @@ -let version = "20151112" +let version = "20160808" diff -Nru menhir-20151112.dfsg/src/yacc-parser.mly menhir-20160808+dfsg/src/yacc-parser.mly --- menhir-20151112.dfsg/src/yacc-parser.mly 2015-11-12 20:02:03.000000000 +0000 +++ menhir-20160808+dfsg/src/yacc-parser.mly 2016-08-08 19:19:04.000000000 +0000 @@ -7,21 +7,20 @@ %{ -open ConcreteSyntax open Syntax open Positions %} -%token TOKEN TYPE LEFT RIGHT NONASSOC START PREC PUBLIC COLON BAR EOF EQUAL +%token TOKEN TYPE LEFT RIGHT NONASSOC START PREC PUBLIC COLON BAR EOF EQUAL %token INLINE LPAREN RPAREN COMMA QUESTION STAR PLUS PARAMETER ON_ERROR_REDUCE -%token LID UID +%token LID UID %token HEADER %token OCAMLTYPE %token PERCENTPERCENT %token Syntax.action> ACTION %start grammar -%type grammar +%type grammar /* These declarations solve a shift-reduce conflict in favor of shifting: when the declaration of a non-terminal symbol begins with @@ -41,12 +40,12 @@ grammar: declarations PERCENTPERCENT rules trailer - { - { - pg_filename = ""; (* filled in by the caller *) - pg_declarations = List.rev $1; - pg_rules = $3; - pg_trailer = $4 + { + { + pg_filename = ""; (* filled in by the caller *) + pg_declarations = List.rev $1; + pg_rules = $3; + pg_trailer = $4 } } @@ -57,7 +56,7 @@ { Some (Lazy.force $1) } /* ------------------------------------------------------------------------- */ -/* A declaration is an %{ Objective Caml header %}, or a %token, %start, +/* A declaration is an %{ OCaml header %}, or a %token, %start, %type, %left, %right, or %nonassoc declaration. */ declarations: @@ -82,7 +81,7 @@ | START OCAMLTYPE nonterminals /* %start foo is syntactic sugar for %start foo %type foo */ - { Misc.mapd (fun ntloc -> + { Misc.mapd (fun ntloc -> Positions.mapd (fun nt -> DStart nt, DType ($2, ParameterVar ntloc)) ntloc) $3 } | priority_keyword symbols @@ -93,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: @@ -172,12 +172,12 @@ production_group production_groups { let public, inline = $1 in - { pr_public_flag = public; - pr_inline_flag = inline; - pr_nt = Positions.value $2; - pr_positions = [ Positions.position $2 ]; - pr_parameters = $3; - pr_branches = List.flatten ($6 :: List.rev $7) + { pr_public_flag = public; + pr_inline_flag = inline; + pr_nt = Positions.value $2; + pr_positions = [ Positions.position $2 ]; + pr_parameters = $3; + pr_branches = List.flatten ($6 :: List.rev $7) } } @@ -218,7 +218,7 @@ { $2 } actuals_comma: - actual + actual { [ $1 ] } | actual COMMA actuals_comma { $1 :: $3 } @@ -277,13 +277,13 @@ (* Distribute the semantic action. Also, check that every [$i] is within bounds. *) let pr_action = action (ParserAux.producer_names producers) in - { - pr_producers; - pr_action; - pr_branch_prec_annotation = ParserAux.override pos oprec1 oprec2; - pr_branch_production_level = level; - pr_branch_position = pos - }) + { + pr_producers; + pr_action; + pr_branch_prec_annotation = ParserAux.override pos oprec1 oprec2; + pr_branch_production_level = level; + pr_branch_position = pos + }) productions } @@ -319,7 +319,7 @@ } producers: - /* epsilon */ + /* epsilon */ { [] } | producers producer { $2 :: $1 } @@ -335,4 +335,3 @@ { Positions.lex_join (symbol_start_pos()) (symbol_end_pos()), Some $1, $3 } %% -